diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2019-07-04 20:30:32 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2019-07-04 20:30:32 -0400 |
| commit | 20b6bd5bc74bbda2a90b0b64800da3d1bb23d51c (patch) | |
| tree | 043adec43075549a9d47bc773850576ccf064025 | |
| parent | 0f1266b1f44434ec960dee31ece22bb480ec912d (diff) | |
| parent | 9ce7a9452e424a3a9c6bec437a0fda0396f0e8b7 (diff) | |
| download | haskell-20b6bd5bc74bbda2a90b0b64800da3d1bb23d51c.tar.gz | |
Merge branch 'wip/ghc-8.8-merges' into ghc-8.8
208 files changed, 2029 insertions, 982 deletions
diff --git a/HACKING.md b/HACKING.md index cb68889904..856f7d609c 100644 --- a/HACKING.md +++ b/HACKING.md @@ -30,7 +30,7 @@ find an overview here: Next, clone the repository and all the associated libraries: ``` -$ git clone --recursive git://git.haskell.org/ghc.git +$ git clone --recursive git@gitlab.haskell.org:ghc/ghc.git ``` On Windows, you need an extra repository containing some build tools. @@ -26,7 +26,7 @@ There are two ways to get a source tree: 2. *Check out the source code from git* - $ git clone --recursive git://git.haskell.org/ghc.git + $ git clone --recursive git@gitlab.haskell.org:ghc/ghc.git Note: cloning GHC from Github requires a special setup. See [Getting a GHC repository from Github][7]. @@ -16,6 +16,11 @@ parser.add_argument('--validate', action='store_true', help='Run in validate mod parser.add_argument('--hadrian', action='store_true', help='Do not assume the make base build system') args = parser.parse_args() +# Packages whose libraries aren't in the submodule root +EXCEPTIONS = { + 'libraries/containers/': 'libraries/containers/containers/' +} + def print_err(s): print(dedent(s), file=sys.stderr) @@ -50,7 +55,7 @@ def check_for_url_rewrites(): Or start over, and clone the GHC repository from the haskell server: - git clone --recursive git://git.haskell.org/ghc.git + git clone --recursive git@gitlab.haskell.org:ghc/ghc.git For more information, see: * https://ghc.haskell.org/trac/ghc/wiki/Newcomers or @@ -78,7 +83,7 @@ def check_boot_packages(): # but in an lndir tree we avoid making .git directories, # so it doesn't exist. We therefore require that every repo # has a LICENSE file instead. - license_path = os.path.join(dir_, 'LICENSE') + license_path = os.path.join(EXCEPTIONS.get(dir_+'/', dir_), 'LICENSE') if not os.path.isfile(license_path): die("""\ Error: %s doesn't exist @@ -91,9 +96,12 @@ def boot_pkgs(): for package in glob.glob("libraries/*/"): packages_file = os.path.join(package, 'ghc-packages') + print(package) if os.path.isfile(packages_file): for subpkg in open(packages_file, 'r'): library_dirs.append(os.path.join(package, subpkg.strip())) + elif package in EXCEPTIONS: + library_dirs.append(EXCEPTIONS[package]) else: library_dirs.append(package) diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 5e91d26c2f..bd67354676 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -511,9 +511,17 @@ hasNoBinding :: Id -> Bool -- Data constructor workers used to be things of this kind, but -- they aren't any more. Instead, we inject a binding for -- them at the CorePrep stage. +-- +-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. +-- for the history of this. +-- +-- Note that CorePrep currently eta expands things no-binding things and this +-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things +-- in CorePrep] in CorePrep for details. +-- -- EXCEPT: unboxed tuples, which definitely have no binding hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Primop wrappers] + PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs FCallId _ -> True DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc _ -> isCompulsoryUnfolding (idUnfolding id) @@ -557,19 +565,6 @@ The easiest way to do this is for hasNoBinding to return True of all things that have compulsory unfolding. A very Ids with a compulsory unfolding also have a binding, but it does not harm to say they don't here, and its a very simple way to fix Trac #14561. - -Note [Primop wrappers] -~~~~~~~~~~~~~~~~~~~~~~ -Currently hasNoBinding claims that PrimOpIds don't have a curried -function definition. But actually they do, in GHC.PrimopWrappers, -which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding -could return 'False' for PrimOpIds. - -But we'd need to add something in CoreToStg to swizzle any unsaturated -applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#. - -Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's -used by GHCi, which does not implement primops direct at all. -} isDeadBinder :: Id -> Bool diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index bf9426ecc8..209d15a57e 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -19,7 +19,7 @@ module PatSyn ( patSynInstArgTys, patSynInstResTy, patSynFieldLabels, patSynFieldType, - tidyPatSynIds, pprPatSynType + updatePatSynIds, pprPatSynType ) where #include "HsVersions.h" @@ -417,8 +417,8 @@ patSynMatcher = psMatcher patSynBuilder :: PatSyn -> Maybe (Id, Bool) patSynBuilder = psBuilder -tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn -tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) +updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } where tidy_pr (id, dummy) = (tidy_fn id, dummy) diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index b5c0fcec58..1fabc1e30f 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -46,7 +46,7 @@ module Unique ( -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] mkAlphaTyVarUnique, - mkPrimOpIdUnique, + mkPrimOpIdUnique, mkPrimOpWrapperUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, mkCoVarUnique, @@ -368,6 +368,8 @@ mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique mkPreludeDataConUnique :: Arity -> Unique mkPrimOpIdUnique :: Int -> Unique +-- See Note [Primop wrappers] in PrimOp.hs. +mkPrimOpWrapperUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkCoVarUnique :: Int -> Unique @@ -405,7 +407,8 @@ dataConWorkerUnique u = incrUnique u dataConTyRepNameUnique u = stepUnique u 2 -------------------------------------------------- -mkPrimOpIdUnique op = mkUnique '9' op +mkPrimOpIdUnique op = mkUnique '9' (2*op) +mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) mkPreludeMiscIdUnique i = mkUnique '0' i -- The "tyvar uniques" print specially nicely: a, b, c, etc. diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 1441ecaa0f..d36a78f13c 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -589,6 +589,7 @@ data CallishMachOp | MO_SubIntC Width | MO_U_Mul2 Width + | MO_ReadBarrier | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 8cc988383e..dda3238987 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -998,6 +998,7 @@ machOps = listToUFM $ callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ + ( "read_barrier", (,) MO_ReadBarrier ), ( "write_barrier", (,) MO_WriteBarrier ), ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), ( "memset", memcpyLikeTweakArgs MO_Memset ), diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 6ebfd20291..e20524ad83 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -806,6 +806,7 @@ pprCallishMachOp_for_C mop MO_F32_Exp -> text "expf" MO_F32_Sqrt -> text "sqrtf" MO_F32_Fabs -> text "fabsf" + MO_ReadBarrier -> text "load_load_barrier" MO_WriteBarrier -> text "write_barrier" MO_Memcpy _ -> text "memcpy" MO_Memset _ -> text "memset" diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index d134dfd677..16be924579 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -630,6 +630,7 @@ emitBlackHoleCode node = do when eager_blackholing $ do emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr + -- See Note [Heap memory barriers] in SMP.h. emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index cf37a8d93b..ea4e210dc0 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -72,7 +72,7 @@ import qualified Data.Set as S The goal of this pass is to prepare for code generation. -1. Saturate constructor and primop applications. +1. Saturate constructor applications. 2. Convert to A-normal form; that is, function arguments are always variables. @@ -1064,8 +1064,21 @@ because that has different strictness. Hence the use of 'allLazy'. -- Building the saturated syntax -- --------------------------------------------------------------------------- -maybeSaturate deals with saturating primops and constructors -The type is the type of the entire application +Note [Eta expansion of hasNoBinding things in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +maybeSaturate deals with eta expanding to saturate things that can't deal with +unsaturated applications (identified by 'hasNoBinding', currently just +foreign calls and unboxed tuple/sum constructors). + +Note that eta expansion in CorePrep is very fragile due to the "prediction" of +CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta +expansion in CorePrep] in TidyPgm for details. We previously saturated primop +applications here as well but due to this fragility (see #16846) we now deal +with this another way, as described in Note [Primop wrappers] in PrimOp. + +It's quite likely that eta expansion of constructor applications will +eventually break in a similar way to how primops did. We really should +eliminate this case as well. -} maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs index be5e6c1619..dfb031df7f 100644 --- a/compiler/coreSyn/CoreTidy.hs +++ b/compiler/coreSyn/CoreTidy.hs @@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm. {-# LANGUAGE CPP #-} module CoreTidy ( - tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding + tidyExpr, tidyRule, tidyRules, tidyUnfolding ) where #include "HsVersions.h" diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 81832c8982..51a0a2b6e1 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -39,6 +39,7 @@ import FastString import DataCon import PatSyn import HscTypes (CompleteMatch(..)) +import BasicTypes (Boxity(..)) import DsMonad import TcSimplify (tcCheckSatisfiability) @@ -1072,12 +1073,17 @@ translatePat fam_insts pat = case pat of TuplePat tys ps boxity -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) - return [vanillaConPattern tuple_con tys (concat tidy_ps)] + tys' = case boxity of + Boxed -> tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + Unboxed -> map getRuntimeRep tys ++ tys + return [vanillaConPattern tuple_con tys' (concat tidy_ps)] SumPat ty p alt arity -> do tidy_p <- translatePat fam_insts (unLoc p) let sum_con = RealDataCon (sumDataCon alt arity) - return [vanillaConPattern sum_con ty tidy_p] + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p] -- -------------------------------------------------------------------------- -- Not supposed to happen @@ -2543,7 +2549,7 @@ warnPmIters dflags (DsMatchContext kind loc) msg is = fsep [ text "Pattern match checker exceeded" , parens (ppr is), text "iterations in", ctxt <> dot , text "(Use -fmax-pmcheck-iterations=n" - , text "to set the maximun number of iterations to n)" ] + , text "to set the maximum number of iterations to n)" ] flag_i = wopt Opt_WarnOverlappingPatterns dflags flag_u = exhaustive dflags kind diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 4d397951b8..1fae72f2ce 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -508,6 +508,7 @@ Library TcTyClsDecls TcTyDecls TcTypeable + TcTypeableValidity TcType TcEvidence TcEvTerm diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 0776e406d6..e3c18b93a2 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -156,7 +156,11 @@ assembleOneBCO hsc_env pbco = do return ubco' assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do +assembleBCO dflags (ProtoBCO { protoBCOName = nm + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity }) = do -- pass 1: collect up the offsets of the local labels. let asm = mapM_ (assembleI dflags) instrs diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 113690780b..0f5d6496dc 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -26,6 +26,7 @@ import Platform import Name import MkId import Id +import Var ( updateVarType ) import ForeignCall import HscTypes import CoreUtils @@ -61,7 +62,6 @@ import Data.Char import UniqSupply import Module -import Control.Arrow ( second ) import Control.Exception import Data.Array @@ -90,7 +90,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks (const ()) $ do -- Split top-level binds into strings and others. -- See Note [generating code for top-level string literal bindings]. - let (strings, flatBinds) = partitionEithers $ do + let (strings, flatBinds) = partitionEithers $ do -- list monad (bndr, rhs) <- flattenBinds binds return $ case exprIsTickedString_maybe rhs of Just str -> Left (bndr, str) @@ -181,29 +181,13 @@ coreExprToBCOs hsc_env this_mod expr where dflags = hsc_dflags hsc_env -- The regular freeVars function gives more information than is useful to --- us here. simpleFreeVars does the impedance matching. +-- us here. We need only the free variables, not everything in an FVAnn. +-- Historical note: At one point FVAnn was more sophisticated than just +-- a set. Now it isn't. So this function is much simpler. Keeping it around +-- so that if someone changes FVAnn, they will get a nice type error right +-- here. simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet -simpleFreeVars = go . freeVars - where - go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet - go (ann, e) = (freeVarsOfAnn ann, go' e) - - go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet - go' (AnnVar id) = AnnVar id - go' (AnnLit lit) = AnnLit lit - go' (AnnLam bndr body) = AnnLam bndr (go body) - go' (AnnApp fun arg) = AnnApp (go fun) (go arg) - go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts) - go' (AnnLet bind body) = AnnLet (go_bind bind) (go body) - go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co) - go' (AnnTick tick body) = AnnTick tick (go body) - go' (AnnType ty) = AnnType ty - go' (AnnCoercion co) = AnnCoercion co - - go_alt (con, args, expr) = (con, args, go expr) - - go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs) - go_bind (AnnRec pairs) = AnnRec (map (second go) pairs) +simpleFreeVars = freeVars -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator @@ -256,6 +240,7 @@ mkProtoBCO -> name -> BCInstrList -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) + -- ^ original expression; for debugging only -> Int -> Word16 -> [StgWord] @@ -368,6 +353,9 @@ schemeR fvs (nm, rhs) -} = schemeR_wrk fvs nm rhs (collect rhs) +-- If an expression is a lambda (after apply bcView), return the +-- list of arguments to the lambda (in R-to-L order) and the +-- underlying expression collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) collect (_, e) = go [] e where @@ -382,8 +370,8 @@ collect (_, e) = go [] e schemeR_wrk :: [Id] -> Id - -> AnnExpr Id DVarSet - -> ([Var], AnnExpr' Var DVarSet) + -> AnnExpr Id DVarSet -- expression e, for debugging only + -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = do @@ -508,8 +496,16 @@ schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (litera schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V schemeE d s p e@(AnnVar v) + -- See Note [Levity-polymorphic join points], step 3. + | isLPJoinPoint v = schemeT d s p $ + AnnApp (bogus_fvs, AnnVar (protectLPJoinPointId v)) + (bogus_fvs, AnnVar voidPrimId) + -- schemeT will call splitApp, dropping the fvs. + | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) | otherwise = schemeT d s p e + where + bogus_fvs = pprPanic "schemeE bogus_fvs" (ppr v) schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, @@ -534,19 +530,22 @@ schemeE d s p (AnnLet binds (_,body)) = do fvss = map (fvsToEnv p' . fst) rhss + -- See Note [Levity-polymorphic join points], step 2. + (xs',rhss') = zipWithAndUnzip protectLPJoinPointBind xs rhss + -- Sizes of free vars size_w = trunc16W . idSizeW dflags sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss -- the arity of each rhs - arities = map (genericLength . fst . collect) rhss + arities = map (genericLength . fst . collect) rhss' -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1 word. d' and p' reflect the stack -- after the closures have been allocated in the heap (but not -- filled in), and pointers to them parked on the stack. offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags)) - p' = Map.insertList (zipE xs offsets) p + p' = Map.insertList (zipE xs' offsets) p d' = d + wordsToBytes dflags n_binds zipE = zipEqual "schemeE" @@ -587,7 +586,7 @@ schemeE d s p (AnnLet binds (_,body)) = do compile_binds = [ compile_bind d' fvs x rhs size arity (trunc16W n) | (fvs, x, rhs, size, arity, n) <- - zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1] ] body_code <- schemeE d' s p' body thunk_codes <- sequence compile_binds @@ -681,6 +680,30 @@ schemeE _ _ _ expr = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' expr)) +-- Is this Id a levity-polymorphic join point? +-- See Note [Levity-polymorphic join points], step 1 +isLPJoinPoint :: Id -> Bool +isLPJoinPoint x = isJoinId x && + isNothing (isLiftedType_maybe (idType x)) + +-- If necessary, modify this Id and body to protect levity-polymorphic join points. +-- See Note [Levity-polymorphic join points], step 2. +protectLPJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet) +protectLPJoinPointBind x rhs@(fvs, _) + | isLPJoinPoint x + = (protectLPJoinPointId x, (fvs, AnnLam voidArgId rhs)) + + | otherwise + = (x, rhs) + +-- Update an Id's type to take a Void# argument. +-- Precondition: the Id is a levity-polymorphic join point. +-- See Note [Levity-polymorphic join points] +protectLPJoinPointId :: Id -> Id +protectLPJoinPointId x + = ASSERT( isLPJoinPoint x ) + updateVarType (voidPrimTy `mkFunTy`) x + {- Ticked Expressions ------------------ @@ -689,6 +712,41 @@ schemeE _ _ _ expr the code. When we find such a thing, we pull out the useful information, and then compile the code as if it was just the expression E. +Note [Levity-polymorphic join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point variable is essentially a goto-label: it is, for example, +never used as an argument to another function, and it is called only +in tail position. See Note [Join points] and Note [Invariants on join points], +both in CoreSyn. Because join points do not compile to true, red-blooded +variables (with, e.g., registers allocated to them), they are allowed +to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points] +in CoreSyn.) + +However, in this byte-code generator, join points *are* treated just as +ordinary variables. There is no check whether a binding is for a join point +or not; they are all treated uniformly. (Perhaps there is a missed optimization +opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) + +We thus must have *some* strategy for dealing with levity-polymorphic join +points (LPJPs), because we cannot have a levity-polymorphic variable. +(Not having such a strategy led to #16509, which panicked in the isUnliftedType +check in the AnnVar case of schemeE.) Here is the strategy: + +1. Detect LPJPs. This is done in isLPJoinPoint. + +2. When binding an LPJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the + type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.) + Note that functions are never levity-polymorphic, so this transformation + changes an LPJP to a non-levity-polymorphic join point. This is done + in protectLPJoinPointBind, called from the AnnLet case of schemeE. + +3. At an occurrence of an LPJP, add an application to void# (called voidPrimId), + being careful to note the new type of the LPJP. This is done in the AnnVar + case of schemeE, with help from protectLPJoinPointId. + +It's a bit hacky, but it works well in practice and is local. I suspect the +Right Fix is to take advantage of join points as goto-labels. + -} -- Compile code to do a tail call. Specifically, push the fn, diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index 07dcd2222a..d405e1ade7 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -45,7 +45,7 @@ data ProtoBCO a protoBCOBitmap :: [StgWord], protoBCOBitmapSize :: Word16, protoBCOArity :: Int, - -- what the BCO came from + -- what the BCO came from, for debugging only protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), -- malloc'd pointers protoBCOFFIs :: [FFIInfo] @@ -179,7 +179,13 @@ data BCInstr -- Printing bytecode instructions instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs bitmap bsize arity origin ffis) + ppr (ProtoBCO { protoBCOName = name + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity + , protoBCOExpr = origin + , protoBCOFFIs = ffis }) = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity <+> text (show ffis) <> colon) $$ nest 3 (case origin of diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index dad13b7bbb..41cc218e12 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -389,8 +389,10 @@ linkCmdLineLibs' hsc_env pls = all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + let merged_specs = mergeStaticObjects cmdline_lib_specs pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls - cmdline_lib_specs + merged_specs + maybePutStr dflags "final link ... " ok <- resolveObjs hsc_env @@ -402,6 +404,19 @@ linkCmdLineLibs' hsc_env pls = return pls1 +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of +-- cyclic symbol references when dynamically linking. Specifically, we link +-- together all of the static objects into a single shared object, avoiding +-- the issue we saw in #13786. +mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] +mergeStaticObjects specs = go [] specs + where + go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] + go accum (Objects objs : rest) = go (objs ++ accum) rest + go accum@(_:_) rest = Objects (reverse accum) : go [] rest + go [] (spec:rest) = spec : go [] rest + go [] [] = [] + {- Note [preload packages] Why do we need to preload packages from the command line? This is an @@ -429,7 +444,7 @@ users? classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) classifyLdInput dflags f - | isObjectFilename platform f = return (Just (Object f)) + | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do putLogMsg dflags NoReason SevInfo noSrcSpan @@ -444,8 +459,8 @@ preloadLib preloadLib hsc_env lib_paths framework_paths pls lib_spec = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of - Object static_ish -> do - (b, pls1) <- preload_static lib_paths static_ish + Objects static_ishs -> do + (b, pls1) <- preload_statics lib_paths static_ishs maybePutStrLn dflags (if b then "done" else "not found") return pls1 @@ -504,13 +519,13 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do intercalate "\n" (map (" "++) paths))) -- Not interested in the paths in the static case. - preload_static _paths name - = do b <- doesFileExist name + preload_statics _paths names + = do b <- or <$> mapM doesFileExist names if not b then return (False, pls) else if dynamicGhc - then do pls1 <- dynLoadObjs hsc_env pls [name] + then do pls1 <- dynLoadObjs hsc_env pls names return (True, pls1) - else do loadObj hsc_env name + else do mapM_ (loadObj hsc_env) names return (True, pls) preload_static_archive _paths name @@ -1166,7 +1181,9 @@ unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do ********************************************************************* -} data LibrarySpec - = Object FilePath -- Full path name of a .o file, including trailing .o + = Objects [FilePath] -- Full path names of set of .o files, including trailing .o + -- We allow batched loading to ensure that cyclic symbol + -- references can be resolved (see #13786). -- For dynamic objects only, try to find the object -- file in all the directories specified in -- v_Library_paths before giving up. @@ -1200,7 +1217,7 @@ partOfGHCi ["base", "template-haskell", "editline"] showLS :: LibrarySpec -> String -showLS (Object nm) = "(static) " ++ nm +showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" showLS (Archive nm) = "(static archive) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm @@ -1299,7 +1316,8 @@ linkPackage hsc_env pkg -- Complication: all the .so's must be loaded before any of the .o's. let known_dlls = [ dll | DLLPath dll <- classifieds ] dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] + objs = [ obj | Objects objs <- classifieds + , obj <- objs ] archs = [ arch | Archive arch <- classifieds ] -- Add directories to library search paths @@ -1507,8 +1525,8 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib (ArchX86_64, OSSolaris2) -> "64" </> so_name _ -> so_name - findObject = liftM (fmap Object) $ findFile dirs obj_file - findDynObject = liftM (fmap Object) $ findFile dirs dyn_obj_file + findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file + findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file findArchive = let local name = liftM (fmap Archive) $ findFile dirs name in apply (map local arch_files) findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index b003cbc123..4790e91425 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -3,7 +3,7 @@ -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. -- -module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where +module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index e978d6feaf..e02ff7efae 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -12,7 +12,7 @@ module LlvmCodeGen.Base ( LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion, supportedLlvmVersion, llvmVersionStr, + LlvmVersion (..), supportedLlvmVersion, llvmVersionStr, LlvmM, runLlvm, liftStream, withClearVars, varLookup, varInsert, @@ -176,14 +176,25 @@ llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags -- -- | LLVM Version Number -type LlvmVersion = (Int, Int) +data LlvmVersion + = LlvmVersion Int + | LlvmVersionOld Int Int + deriving Eq + +-- Custom show instance for backwards compatibility. +instance Show LlvmVersion where + show (LlvmVersion maj) = show maj + show (LlvmVersionOld maj min) = show maj ++ "." ++ show min -- | The LLVM Version that is currently supported. supportedLlvmVersion :: LlvmVersion -supportedLlvmVersion = sUPPORTED_LLVM_VERSION +supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION llvmVersionStr :: LlvmVersion -> String -llvmVersionStr (major, minor) = show major ++ "." ++ show minor +llvmVersionStr v = + case v of + LlvmVersion maj -> show maj + LlvmVersionOld maj min -> show maj ++ "." ++ show min -- ---------------------------------------------------------------------------- -- * Environment Handling diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index f6b47b091c..141eb957cc 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -169,17 +169,25 @@ barrier = do let s = Fence False SyncSeqCst return (unitOL s, []) +-- | Insert a 'barrier', unless the target platform is in the provided list of +-- exceptions (where no code will be emitted instead). +barrierUnless :: [Arch] -> LlvmM StmtData +barrierUnless exs = do + platform <- getLlvmPlatform + if platformArch platform `elem` exs + then return (nilOL, []) + else barrier + -- | Foreign Calls genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData --- Write barrier needs to be handled specially as it is implemented as an LLVM --- intrinsic function. +-- Barriers need to be handled specially as they are implemented as LLVM +-- intrinsic functions. +genCall (PrimTarget MO_ReadBarrier) _ _ = + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] genCall (PrimTarget MO_WriteBarrier) _ _ = do - platform <- getLlvmPlatform - if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] - then return (nilOL, []) - else barrier + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] genCall (PrimTarget MO_Touch) _ _ = return (nilOL, []) @@ -824,6 +832,7 @@ cmmPrimOpFunctions mop = do -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the -- appropriate case of genCall. MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported MO_UF_Conv _ -> unsupported diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5d3dbafdbb..ef6152430d 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -56,7 +56,7 @@ import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc -import LlvmCodeGen ( llvmFixupAsm ) +import LlvmCodeGen ( LlvmVersion (..), llvmFixupAsm ) import MonadUtils import Platform import TcRnTypes @@ -1193,9 +1193,6 @@ runPhase (RealPhase Cmm) input_fn dflags ----------------------------------------------------------------------------- -- Cc phase --- we don't support preprocessing .c files (with -E) now. Doing so introduces --- way too many hacks, and I can't say I've ever used it anyway. - runPhase (RealPhase cc_phase) input_fn dflags | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] = do @@ -1217,6 +1214,16 @@ runPhase (RealPhase cc_phase) input_fn dflags (includePathsQuote cmdline_include_paths) let include_paths = include_paths_quote ++ include_paths_global + -- pass -D or -optP to preprocessor when compiling foreign C files + -- (#16737). Doing it in this way is simpler and also enable the C + -- compiler to performs preprocessing and parsing in a single pass, + -- but it may introduce inconsistency if a different pgm_P is specified. + let more_preprocessor_opts = concat + [ ["-Xpreprocessor", i] + | not hcc + , i <- getOpts dflags opt_P + ] + let gcc_extra_viac_flags = extraGccViaCFlags dflags let pic_c_flags = picCCOpts dflags @@ -1226,7 +1233,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. pkg_extra_cc_opts <- liftIO $ - if cc_phase `eqPhase` HCc + if hcc then return [] else getPackageExtraCcOpts dflags pkgs @@ -1317,6 +1324,7 @@ runPhase (RealPhase cc_phase) input_fn dflags ++ [ "-include", ghcVersionH ] ++ framework_paths ++ include_paths + ++ more_preprocessor_opts ++ pkg_extra_cc_opts )) @@ -2163,7 +2171,8 @@ getBackendDefs :: DynFlags -> IO [String] getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags return $ case llvmVer of - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] + Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] + Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] _ -> [] where format (major, minor) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 4ce4d69744..a7ec70f876 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -2713,7 +2713,7 @@ updOptLevel n dfs -- Parsing the dynamic flags. --- | Parse dynamic flags from a list of command line arguments. Returns the +-- | Parse dynamic flags from a list of command line arguments. Returns -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index ac97f173f2..4488d9cf88 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -80,6 +80,7 @@ import Data.IORef import Data.Maybe ( fromMaybe ) import Data.Ord import Data.Time +import Debug.Trace import Control.Monad import Control.Monad.IO.Class import System.IO @@ -598,9 +599,10 @@ fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () -compilationProgressMsg dflags msg - = ifVerbose dflags 1 $ - logOutput dflags (defaultUserStyle dflags) (text msg) +compilationProgressMsg dflags msg = do + traceEventIO $ "GHC progress: " ++ msg + ifVerbose dflags 1 $ + logOutput dflags (defaultUserStyle dflags) (text msg) showPass :: DynFlags -> String -> IO () showPass dflags what @@ -641,10 +643,12 @@ withTiming getDFlags what force_result action if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do liftIO $ logInfo dflags (defaultUserStyle dflags) $ text "***" <+> what <> colon + liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what alloc0 <- liftIO getAllocationCounter start <- liftIO getCPUTime !r <- action () <- pure $ force_result r + liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what end <- liftIO getCPUTime alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 03e0cb341a..7dbf5203bb 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -2089,6 +2089,7 @@ enableCodeGenForUnboxedTuples = enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule where condition ms = + False && -- disabled due to #16876 xopt LangExt.UnboxedTuples (ms_hspp_opts ms) && not (isBootSummary ms) should_modify (ModSummary { ms_hspp_opts = dflags }) = diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 9825ee48c7..879e6c75ac 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -507,7 +507,9 @@ tcRnModule' sum save_rn_syntax mod = do safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') when safe $ do case wopt Opt_WarnSafe dflags of - True -> (logWarnings $ unitBag $ + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnSafe) $ mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res') diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 44258de70c..e80574c0d1 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -1456,23 +1456,42 @@ mkPackageState dflags dbs preload0 = do let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 -- - -- Calculate the initial set of packages, prior to any package flags. - -- This set contains the latest version of all valid (not unusable) packages, - -- or is empty if we have -hide-all-packages + -- Calculate the initial set of units from package databases, prior to any package flags. -- - let preferLater pkg pkg' = - case compareByPreference prec_map pkg pkg' of - GT -> pkg - _ -> pkg' - calcInitial m pkg = addToUDFM_C preferLater m (fsPackageName pkg) pkg - initial = if gopt Opt_HideAllPackages dflags + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags then emptyUDFM - else foldl' calcInitial emptyUDFM pkgs1 - vis_map1 = foldUDFM (\p vm -> + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same pacakge name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> -- Note: we NEVER expose indefinite packages by -- default, because it's almost assuredly not -- what you want (no mix-in linking has occurred). - if exposed p && unitIdIsDefinite (packageConfigId p) + if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p then Map.insert (packageConfigId p) UnitVisibility { uv_expose_all = True, @@ -1483,7 +1502,7 @@ mkPackageState dflags dbs preload0 = do } vm else vm) - Map.empty initial + Map.empty pkgs1 -- -- Compute a visibility map according to the command-line flags (-package, diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs index a986db2fc0..45d2efbbbf 100644 --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -22,7 +22,7 @@ import System.IO import System.Process import GhcPrelude -import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion) +import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion) import SysTools.Process import SysTools.Info @@ -184,7 +184,7 @@ runClang dflags args = do ) -- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int)) +figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) figureLlvmVersion dflags = do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) @@ -206,8 +206,10 @@ figureLlvmVersion dflags = do vline <- dropWhile (not . isDigit) `fmap` hGetLine pout v <- case span (/= '.') vline of ("",_) -> fail "no digits!" - (x,y) -> return (read x - , read $ takeWhile isDigit $ drop 1 y) + (x,"") -> return $ LlvmVersion (read x) + (x,y) -> return $ LlvmVersionOld + (read x) + (read $ takeWhile isDigit $ drop 1 y) hClose pin hClose pout diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index e9f3f85317..c96a2f2843 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP, ViewPatterns #-} module TidyPgm ( - mkBootModDetailsTc, tidyProgram, globaliseAndTidyId + mkBootModDetailsTc, tidyProgram ) where #include "HsVersions.h" @@ -39,13 +39,11 @@ import Id import MkId ( mkDictSelRhs ) import IdInfo import InstEnv -import FamInstEnv import Type ( tidyTopType ) import Demand ( appIsBottom, isTopSig, isBottomingSig ) import BasicTypes import Name hiding (varName) import NameSet -import NameEnv import NameCache import Avail import IfaceEnv @@ -60,6 +58,7 @@ import HscTypes import Maybes import UniqSupply import Outputable +import Util( filterOut ) import qualified ErrUtils as Err import Control.Monad @@ -135,78 +134,92 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc hsc_env - TcGblEnv{ tcg_exports = exports, - tcg_type_env = type_env, -- just for the Ids - tcg_tcs = tcs, - tcg_patsyns = pat_syns, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_mod = this_mod + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_patsyns = pat_syns, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_complete_matches = complete_sigs, + tcg_mod = this_mod } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process. Err.withTiming (pure dflags) (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ - do { let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts - ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns - ; type_env1 = mkBootTypeEnv (availsToNameSet exports) - (typeEnvIds type_env) tcs fam_insts - ; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 - ; dfun_ids = map instanceDFunId insts' - ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids - } - ; return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports - , md_complete_sigs = [] - }) - } + return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_complete_sigs = complete_sigs + }) where dflags = hsc_dflags hsc_env -mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv -mkBootTypeEnv exports ids tcs fam_insts - = tidyTypeEnv True $ - typeEnvFromEntities final_ids tcs fam_insts - where - -- Find the LocalIds in the type env that are exported - -- Make them into GlobalIds, and tidy their types - -- - -- It's very important to remove the non-exported ones - -- because we don't tidy the OccNames, and if we don't remove - -- the non-exported ones we'll get many things with the - -- same name in the interface file, giving chaos. - -- - -- Do make sure that we keep Ids that are already Global. - -- When typechecking an .hs-boot file, the Ids come through as - -- GlobalIds. - final_ids = [ (if isLocalId id then globaliseAndTidyId id - else id) - `setIdUnfolding` BootUnfolding - | id <- ids + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ globaliseAndTidyBootId id + | id <- typeEnvIds type_env , keep_it id ] - -- default methods have their export flag set, but everything - -- else doesn't (yet), because this is pre-desugaring, so we - -- must test both. - keep_it id = isExportedId id || idName id `elemNameSet` exports - + final_tcs = filterOut (isWiredInName . getName) tcs + -- See Note [Drop wired-in things] + type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts + insts' = mkFinalClsInsts type_env1 insts + pat_syns' = mkFinalPatSyns type_env1 pat_syns + type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 + + -- Default methods have their export flag set (isExportedId), + -- but everything else doesn't (yet), because this is + -- pre-desugaring, so we must test against the exports too. + keep_it id | isWiredInName id_name = False + -- See Note [Drop wired-in things] + | isExportedId id = True + | id_name `elemNameSet` exp_names = True + | otherwise = False + where + id_name = idName id + + exp_names = availsToNameSet exports + +lookupFinalId :: TypeEnv -> Id -> Id +lookupFinalId type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _ -> pprPanic "lookup_final_id" (ppr id) + +mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] +mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) + +mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] +mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) +extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv +extendTypeEnvWithPatSyns tidy_patsyns type_env + = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] -globaliseAndTidyId :: Id -> Id --- Takes a LocalId with an External Name, +globaliseAndTidyBootId :: Id -> Id +-- For a LocalId with an External Name, -- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details --- * VanillaIdInfo (makes a conservative assumption about Caf-hood) -globaliseAndTidyId id - = Id.setIdType (globaliseId id) tidy_type - where - tidy_type = tidyTopType (idType id) +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity) +-- * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface) +globaliseAndTidyBootId id + = globaliseId id `setIdType` tidyTopType (idType id) + `setIdUnfolding` BootUnfolding {- ************************************************************************ @@ -334,13 +347,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; print_unqual = mkPrintUnqualified dflags rdr_env - } - - ; let { type_env = typeEnvFromEntities [] tcs fam_insts - - ; implicit_binds - = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ - concatMap getTyConImplicitBinds (typeEnvTyCons type_env) + ; implicit_binds = concatMap getImplicitBinds tcs } ; (unfold_env, tidy_occ_env) @@ -352,30 +359,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds - ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, - isExternalName (idName id)] - ; type_env1 = extendTypeEnvWithIds type_env final_ids - - ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts - -- A DFunId will have a binding in tidy_binds, and so will now be in - -- tidy_type_env, replete with IdInfo. Its name will be unchanged since - -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the - -- tidy_cls_insts. Similarly the Ids inside a PatSyn. - - ; tidy_rules = tidyRules tidy_env trimmed_rules - -- You might worry that the tidy_env contains IdInfo-rich stuff - -- and indeed it does, but if omit_prags is on, ext_rules is - -- empty - - -- Tidy the Ids inside each PatSyn, very similarly to DFunIds - -- and then override the PatSyns in the type_env with the new tidy ones - -- This is really the only reason we keep mg_patsyns at all; otherwise - -- they could just stay in type_env - ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns - ; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1 - - ; tidy_type_env = tidyTypeEnv omit_prags type_env2 - } -- See Note [Grand plan for static forms] in StaticPtrTable. ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds @@ -387,20 +370,44 @@ tidyProgram hsc_env (ModGuts { mg_module = mod HscInterpreted -> id -- otherwise add a C stub to do so _ -> (`appendStubC` spt_init_code) - } - ; let { -- See Note [Injecting implicit bindings] + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + ; final_ids = [ if omit_prags then trimId id else id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredInName (getName id)) + ] -- See Note [Drop wired-in things] + + ; final_tcs = filterOut (isWiredInName . getName) tcs + -- See Note [Drop wired-in things] + ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts + ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts + ; tidy_patsyns = mkFinalPatSyns type_env patsyns + ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + ; tidy_rules = tidyRules tidy_env trimmed_rules + + ; -- See Note [Injecting implicit bindings] all_tidy_binds = implicit_binds ++ tidy_binds' -- Get the TyCons to generate code for. Careful! We must use - -- the untidied TypeEnv here, because we need + -- the untidied TyCons here, because we need -- (a) implicit TyCons arising from types and classes defined -- in this module -- (b) wired-in TyCons, which are normally removed from the -- TypeEnv we put in the ModDetails -- (c) Constructors even if they are not exported (the -- tidied TypeEnv has trimmed these away) - ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + ; alg_tycons = filter isAlgTyCon tcs } ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules @@ -443,46 +450,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod where dflags = hsc_dflags hsc_env -tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> TypeEnv -> TypeEnv - --- The completed type environment is gotten from --- a) the types and classes defined here (plus implicit things) --- b) adding Ids with correct IdInfo, including unfoldings, --- gotten from the bindings --- From (b) we keep only those Ids with External names; --- the CoreTidy pass makes sure these are all and only --- the externally-accessible ones --- This truncates the type environment to include only the --- exported Ids and things needed from them, which saves space --- --- See Note [Don't attempt to trim data types] - -tidyTypeEnv omit_prags type_env - = let - type_env1 = filterNameEnv (not . isWiredInName . getName) type_env - -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv trimThing type_env1 - | otherwise = type_env1 - -- (2) trimmed if necessary - in - type_env2 - -------------------------- -trimThing :: TyThing -> TyThing --- Trim off inessentials, for boot files and no -O -trimThing (AnId id) - | not (isImplicitId id) - = AnId (id `setIdInfo` vanillaIdInfo) - -trimThing other_thing - = other_thing +trimId :: Id -> Id +trimId id + | not (isImplicitId id) + = id `setIdInfo` vanillaIdInfo + | otherwise + = id -extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv -extendTypeEnvWithPatSyns tidy_patsyns type_env - = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] +{- Note [Drop wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never put wired-in TyCons or Ids in an interface file. +They are wired-in, so the compiler knows about them already. -{- Note [Don't attempt to trim data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For some time GHC tried to avoid exporting the data constructors @@ -564,6 +544,11 @@ really just a code generation trick.... binding itself makes no sense. See Note [Data constructor workers] in CorePrep. -} +getImplicitBinds :: TyCon -> [CoreBind] +getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc + where + cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) + getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) @@ -1300,7 +1285,48 @@ So we have to *predict* the result here, which is revolting. In particular CorePrep expands Integer and Natural literals. So in the prediction code here we resort to applying the same expansion (cvt_literal). -Ugh! +There are also numberous other ways in which we can introduce inconsistencies +between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta +expansion in TidyPgm] for one such example. + +Ugh! What ugliness we hath wrought. + + +Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Eta expansion during CorePrep can have non-obvious negative consequences on +the CAFfyness computation done by TidyPgm (see Note [Disgusting computation of +CafRefs] in TidyPgm). This late expansion happens/happened for a few reasons: + + * CorePrep previously eta expanded unsaturated primop applications, as + described in Note [Primop wrappers]). + + * CorePrep still does eta expand unsaturated data constructor applications. + +In particular, consider the program: + + data Ty = Ty (RealWorld# -> (# RealWorld#, Int #)) + + -- Is this CAFfy? + x :: STM Int + x = Ty (retry# @Int) + +Consider whether x is CAFfy. One might be tempted to answer "no". +Afterall, f obviously has no CAF references and the application (retry# +@Int) is essentially just a variable reference at runtime. + +However, when CorePrep expanded the unsaturated application of 'retry#' +it would rewrite this to + + x = \u [] + let sat = retry# @Int + in Ty sat + +This is now a CAF. Failing to handle this properly was the cause of +#16846. We fixed this by eliminating the need to eta expand primops, as +described in Note [Primop wrappers]), However we have not yet done the same for +data constructor applications. + -} type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 516a49aee3..2ee560872e 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -943,6 +943,7 @@ condIntCode' True cond W64 x y , BCC LE cmp_lo Nothing , CMPL II32 x_lo (RIReg y_lo) , BCC ALWAYS end_lbl Nothing + , NEWBLOCK cmp_lo , CMPL II32 y_lo (RIReg x_lo) , BCC ALWAYS end_lbl Nothing @@ -1116,6 +1117,8 @@ genCCall :: ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock +genCCall (PrimTarget MO_ReadBarrier) _ _ + = return $ unitOL LWSYNC genCCall (PrimTarget MO_WriteBarrier) _ _ = return $ unitOL LWSYNC @@ -2020,6 +2023,7 @@ genCCall' dflags gcp target dest_regs args MO_AddIntC {} -> unsupported MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported MO_Prefetch_Data _ -> unsupported diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index e618e189b8..c0c5548ae3 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -98,7 +98,7 @@ ppc_mkStackAllocInstr' platform amount , STU fmt r0 (AddrRegReg sp tmp) ] where - fmt = intFormat $ widthFromBytes ((platformWordSize platform) `quot` 8) + fmt = intFormat $ widthFromBytes (platformWordSize platform) zero = ImmInt 0 tmp = tmpReg platform immAmount = ImmInt amount diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 83402bb126..becd2bf24e 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -401,6 +401,8 @@ genCCall -- -- In the SPARC case we don't need a barrier. -- +genCCall (PrimTarget MO_ReadBarrier) _ _ + = return $ nilOL genCCall (PrimTarget MO_WriteBarrier) _ _ = return $ nilOL @@ -686,6 +688,7 @@ outOfLineMachOp_table mop MO_AddIntC {} -> unsupported MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported (MO_Prefetch_Data _) -> unsupported diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 37080b990e..69ab7b202d 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1888,8 +1888,9 @@ genCCall dflags _ (PrimTarget (MO_Memset align)) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) +genCCall _ _ (PrimTarget MO_ReadBarrier) _ _ _ = return nilOL genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; + -- barriers compile to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL @@ -2931,6 +2932,7 @@ outOfLineCmmOp bid mop res args MO_AddWordC {} -> unsupported MO_SubWordC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported (MO_Prefetch_Data _ ) -> unsupported diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index aab23de20f..37fee2c337 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -131,6 +131,7 @@ knownKeyNames , map idName wiredInIds , map (idName . primOpId) allThePrimOps + , map (idName . primOpWrapperId) allThePrimOps , basicKnownKeyNames , templateHaskellNames ] diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index a5330505ae..7c60ff9aa4 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -498,7 +498,8 @@ pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, + gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, + gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, @@ -516,10 +517,12 @@ gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") +gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers") gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") +gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers") gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index 017839e8d1..d70caaedfc 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -13,6 +13,7 @@ module PrimOp ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, primOpType, primOpSig, primOpTag, maxPrimOpTag, primOpOcc, + primOpWrapperId, tagToEnumKey, @@ -34,14 +35,18 @@ import TysWiredIn import CmmType import Demand -import OccName ( OccName, pprOccName, mkVarOccFS ) +import Id ( Id, mkVanillaGlobalWithInfo ) +import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) +import Name +import PrelNames ( gHC_PRIMOPWRAPPERS ) import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import Type import RepType ( typePrimRep1, tyConPrimRep1 ) import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), SourceText(..) ) +import SrcLoc ( wiredInSrcSpan ) import ForeignCall ( CLabelString ) -import Unique ( Unique, mkPrimOpIdUnique ) +import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import Outputable import FastString import Module ( UnitId ) @@ -572,6 +577,47 @@ primOpOcc op = case primOpInfo op of Compare occ _ -> occ GenPrimOp occ _ _ _ -> occ +{- Note [Primop wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously hasNoBinding would claim that PrimOpIds didn't have a curried +function definition. This caused quite some trouble as we would be forced to +eta expand unsaturated primop applications very late in the Core pipeline. Not +only would this produce unnecessary thunks, but it would also result in nasty +inconsistencies in CAFfy-ness determinations (see #16846 and +Note [CAFfyness inconsistencies due to late eta expansion] in TidyPgm). + +However, it was quite unnecessary for hasNoBinding to claim this; primops in +fact *do* have curried definitions which are found in GHC.PrimopWrappers, which +is auto-generated by utils/genprimops from prelude/primops.txt.pp. These wrappers +are standard Haskell functions mirroring the types of the primops they wrap. +For instance, in the case of plusInt# we would have: + + module GHC.PrimopWrappers where + import GHC.Prim as P + plusInt# a b = P.plusInt# a b + +We now take advantage of these curried definitions by letting hasNoBinding +claim that PrimOpIds have a curried definition and then rewrite any unsaturated +PrimOpId applications that we find during CoreToStg as applications of the +associated wrapper (e.g. `GHC.Prim.plusInt# 3#` will get rewritten to +`GHC.PrimopWrappers.plusInt# 3#`).` The Id of the wrapper for a primop can be +found using 'PrimOp.primOpWrapperId'. + +Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's +used by GHCi, which does not implement primops direct at all. + +-} + +-- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'. +-- See Note [Primop wrappers]. +primOpWrapperId :: PrimOp -> Id +primOpWrapperId op = mkVanillaGlobalWithInfo name ty info + where + info = setCafInfo vanillaIdInfo NoCafRefs + name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan + uniq = mkPrimOpWrapperUnique (primOpTag op) + ty = primOpType op + isComparisonPrimOp :: PrimOp -> Bool isComparisonPrimOp op = case primOpInfo op of Compare {} -> True diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 51e1d7de5e..9ad2065e61 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -1268,9 +1268,13 @@ simplCast env body co0 cont0 addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + , Pair hole_ty _ <- coercionKind co = {-#SCC "addCoerce-pushCoTyArg" #-} do { tail' <- addCoerceM m_co' tail - ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) } + ; return (cont { sc_arg_ty = arg_ty' + , sc_hole_ty = hole_ty -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + , sc_cont = tail' }) } addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail }) diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs index 4d437d3b7c..522eeb1ab3 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -64,7 +64,7 @@ isNvUnaryType ty = False -- INVARIANT: the result list is never empty. -typePrimRepArgs :: Type -> [PrimRep] +typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] typePrimRepArgs ty | [] <- reps = [VoidRep] diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index e8f159b569..e461d45bd4 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -45,7 +45,7 @@ import Util import DynFlags import ForeignCall import Demand ( isUsedOnce ) -import PrimOp ( PrimCall(..) ) +import PrimOp ( PrimCall(..), primOpWrapperId ) import SrcLoc ( mkGeneralSrcSpan ) import Data.List.NonEmpty (nonEmpty, toList) @@ -268,7 +268,7 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) bind = StgTopLifted $ StgNonRec id stg_rhs in - ASSERT2(consistentCafInfo id bind, ppr id ) + assertConsistentCaInfo dflags id bind (ppr bind) -- NB: previously the assertion printed 'rhs' and 'bind' -- as well as 'id', but that led to a black hole -- where printing the assertion error tripped the @@ -296,9 +296,18 @@ coreTopBindToStg dflags this_mod env ccs (Rec pairs) bind = StgTopLifted $ StgRec (zip binders stg_rhss) in - ASSERT2(consistentCafInfo (head binders) bind, ppr binders) + assertConsistentCaInfo dflags (head binders) bind (ppr binders) (env', ccs', bind) +-- | CAF consistency issues will generally result in segfaults and are quite +-- difficult to debug (see #16846). We enable checking of the +-- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that +-- we catch these issues. +assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a +assertConsistentCaInfo dflags id bind err_doc result + | gopt Opt_DoStgLinting dflags || debugIsOn + , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc + | otherwise = result -- Assertion helper: this checks that the CafInfo on the Id matches -- what CoreToStg has figured out about the binding's SRT. The @@ -528,8 +537,12 @@ coreToStgApp _ f args ticks = do (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) -- Some primitive operator that might be implemented as a library call. - PrimOpId op -> ASSERT( saturated ) - StgOpApp (StgPrimOp op) args' res_ty + -- As described in Note [Primop wrappers] in PrimOp.hs, here we + -- turn unsaturated primop applications into applications of + -- the primop's wrapper. + PrimOpId op + | saturated -> StgOpApp (StgPrimOp op) args' res_ty + | otherwise -> StgApp (primOpWrapperId op) args' -- A call to some primitive Cmm function. FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs index 516b89849f..6487ad11ed 100644 --- a/compiler/typecheck/ClsInst.hs +++ b/compiler/typecheck/ClsInst.hs @@ -16,6 +16,7 @@ import TcRnMonad import TcType import TcMType import TcEvidence +import TcTypeableValidity import RnEnv( addUsedGRE ) import RdrName( lookupGRE_FieldLabel ) import InstEnv @@ -432,7 +433,7 @@ doFunTy clas ty arg_ty ret_ty -- of monomorphic kind (e.g. all kind variables have been instantiated). doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args - | Just _ <- tyConRepName_maybe tc + | tyConIsTypeable tc = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args) , cir_mk_ev = mk_ev , cir_what = BuiltinInstance } diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index d643925127..740038e0c5 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -2079,13 +2079,6 @@ What do we do when we have an equality where k1 and k2 differ? This Note explores this treacherous area. -First off, the question above is slightly the wrong question. Flattening -a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening -the kind might introduce a cast. So we might have a casted tyvar on the -left. We thus revise our test case to - - (tv |> co :: k1) ~ (rhs :: k2) - We must proceed differently here depending on whether we have a Wanted or a Given. Consider this: @@ -2109,36 +2102,33 @@ The reason for this odd behavior is much the same as Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the new `co` is a Wanted. - The solution is then not to use `co` to "rewrite" -- that is, cast - -- `w`, but instead to keep `w` heterogeneous and - irreducible. Given that we're not using `co`, there is no reason to - collect evidence for it, so `co` is born a Derived, with a CtOrigin - of KindEqOrigin. +The solution is then not to use `co` to "rewrite" -- that is, cast -- `w`, but +instead to keep `w` heterogeneous and irreducible. Given that we're not using +`co`, there is no reason to collect evidence for it, so `co` is born a +Derived, with a CtOrigin of KindEqOrigin. When the Derived is solved (by +unification), the original wanted (`w`) will get kicked out. We thus get -When the Derived is solved (by unification), the original wanted (`w`) -will get kicked out. +[D] _ :: k ~ Type +[W] w :: (alpha :: k) ~ (Int :: Type) -Note that, if we had [G] co1 :: k ~ Type available, then none of this code would -trigger, because flattening would have rewritten k to Type. That is, -`w` would look like [W] (alpha |> co1 :: Type) ~ (Int :: Type), and the tyvar -case will trigger, correctly rewriting alpha to (Int |> sym co1). +Note that the Wanted is unchanged and will be irreducible. This all happens +in canEqTyVarHetero. + +Note that, if we had [G] co1 :: k ~ Type available, then we never get +to canEqTyVarHetero: canEqTyVar tries flattening the kinds first. If +we have [G] co1 :: k ~ Type, then flattening the kind of alpha would +rewrite k to Type, and we would end up in canEqTyVarHomo. Successive canonicalizations of the same Wanted may produce duplicate Deriveds. Similar duplications can happen with fundeps, and there seems to be no easy way to avoid. I expect this case to be rare. -For Givens, this problem doesn't bite, so a heterogeneous Given gives +For Givens, this problem (the Wanteds-rewriting-Wanteds action of +a kind coercion) doesn't bite, so a heterogeneous Given gives rise to a Given kind equality. No Deriveds here. We thus homogenise -the Given (see the "homo_co" in the Given case in canEqTyVar) and +the Given (see the "homo_co" in the Given case in canEqTyVarHetero) and carry on with a homogeneous equality constraint. -Separately, I (Richard E) spent some time pondering what to do in the case -that we have [W] (tv |> co1 :: k1) ~ (tv |> co2 :: k2) where k1 and k2 -differ. Note that the tv is the same. (This case is handled as the first -case in canEqTyVarHomo.) At one point, I thought we could solve this limited -form of heterogeneous Wanted, but I then reconsidered and now treat this case -just like any other heterogeneous Wanted. - Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat type synonym applications as xi types, that is, they do not diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index df307f240c..62d918a242 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -158,14 +158,22 @@ reportUnsolved wanted -- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on -- However, do not make any evidence bindings, because we don't -- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. -- See Note [Deferring coercion errors to runtime] -- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in TcSimplify] +-- (see Note [Fail fast on kind errors] in TcSimplify) -- and for simplifyDefault. reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds - ; report_unsolved TypeError HoleError HoleError HoleError + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; let type_holes | not partial_sigs = HoleError + | warn_partial_sigs = HoleWarn + | otherwise = HoleDefer + + ; report_unsolved TypeError HoleError type_holes HoleError ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 6ff9729e69..5c268c078c 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -11,7 +11,7 @@ module TcHsType ( -- Type signatures - kcHsSigType, tcClassSigType, + kcClassSigType, tcClassSigType, tcHsSigType, tcHsSigWcType, tcHsPartialSigType, funsSigCtxt, addSigCtxt, pprSigCtxt, @@ -187,24 +187,40 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type -- already checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM () -kcHsSigType names (HsIB { hsib_body = hs_ty - , hsib_ext = sig_vars }) - = addSigCtxt (funsSigCtxt names) hs_ty $ - discardResult $ - bindImplicitTKBndrs_Skol sig_vars $ - tc_lhs_type typeLevelMode hs_ty liftedTypeKind - -kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType" +kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () +kcClassSigType skol_info names sig_ty + = discardResult $ + tcClassSigType skol_info names sig_ty + -- tcClassSigType does a fair amount of extra work that we don't need, + -- such as ordering quantified variables. But we absolutely do need + -- to push the level when checking method types and solve local equalities, + -- and so it seems easier just to call tcClassSigType than selectively + -- extract the lines of code from tc_hs_sig_type that we really need. + -- If we don't push the level, we get #16517, where GHC accepts + -- class C a where + -- meth :: forall k. Proxy (a :: k) -> () + -- Note that k is local to meth -- this is hogwash. tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType skol_info names sig_ty = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) -- Do not zonk-to-Type, nor perform a validity check -- We are in a knot with the class and associated types -- Zonking and validity checking is done by tcClassDecl + -- No need to fail here if the type has an error: + -- If we're in the kind-checking phase, the solveEqualities + -- in kcTyClGroup catches the error + -- If we're in the type-checking phase, the solveEqualities + -- in tcClassDecl1 gets it + -- Failing fast here degrades the error message in, e.g., tcfail135: + -- class Foo f where + -- baa :: f a -> f + -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. + -- It should be that f has kind `k2 -> *`, but we never get a chance + -- to run the solver where the kind of f is touchable. This is + -- painfully delicate. tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Does validity checking @@ -214,10 +230,13 @@ tcHsSigType ctxt sig_ty do { traceTc "tcHsSigType {" (ppr sig_ty) -- Generalise here: see Note [Kind generalisation] - ; ty <- tc_hs_sig_type skol_info sig_ty - (expectedKindInCtxt ctxt) + ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty + (expectedKindInCtxt ctxt) ; ty <- zonkTcType ty + ; when insol failM + -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify + ; checkValidType ctxt ty ; traceTc "end tcHsSigType }" (ppr ty) ; return ty } @@ -225,12 +244,14 @@ tcHsSigType ctxt sig_ty skol_info = SigTypeSkol ctxt tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM Type + -> ContextKind -> TcM (Bool, TcType) -- Kind-checks/desugars an 'LHsSigType', -- solve equalities, -- and then kind-generalizes. -- This will never emit constraints, as it uses solveEqualities interally. -- No validity checking or zonking +-- Returns also a Bool indicating whether the type induced an insoluble constraint; +-- True <=> constraint is insoluble tc_hs_sig_type skol_info hs_sig_type ctxt_kind | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type = do { (tc_lvl, (wanted, (spec_tkvs, ty))) @@ -249,9 +270,9 @@ tc_hs_sig_type skol_info hs_sig_type ctxt_kind ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) tc_lvl wanted - ; return (mkInvForAllTys kvs ty1) } + ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } -tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen" +tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type" tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type -- tcTopLHsType is used for kind-checking top-level HsType where @@ -2056,7 +2077,8 @@ kindGeneralize :: TcType -> TcM [KindVar] -- Quantify the free kind variables of a kind or type -- In the latter case the type is closed, so it has no free -- type variables. So in both cases, all the free vars are kind vars --- Input needn't be zonked. +-- Input needn't be zonked. All variables to be quantified must +-- have a TcLevel higher than the ambient TcLevel. -- NB: You must call solveEqualities or solveLocalEqualities before -- kind generalization -- @@ -2074,7 +2096,8 @@ kindGeneralize kind_or_type -- | This variant of 'kindGeneralize' refuses to generalize over any -- variables free in the given WantedConstraints. Instead, it promotes --- these variables into an outer TcLevel. See also +-- these variables into an outer TcLevel. All variables to be quantified must +-- have a TcLevel higher than the ambient TcLevel. See also -- Note [Promoting unification variables] in TcSimplify kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar] kindGeneralizeLocal wanted kind_or_type diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index ffeb602382..ce7c1ee1aa 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -759,14 +759,14 @@ writeMetaTyVar tyvar ty -- Everything from here on only happens if DEBUG is on | not (isTcTyVar tyvar) - = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar ) + = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) return () | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar = writeMetaTyVarRef tyvar ref ty | otherwise - = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) + = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) return () -------------------- @@ -1066,18 +1066,18 @@ we are trying to generalise this type: forall arg. ... (alpha[tau]:arg) ... We have a metavariable alpha whose kind mentions a skolem variable -boudn inside the very type we are generalising. +bound inside the very type we are generalising. This can arise while type-checking a user-written type signature (see the test case for the full code). We cannot generalise over alpha! That would produce a type like forall {a :: arg}. forall arg. ...blah... The fact that alpha's kind mentions arg renders it completely -ineligible for generaliation. +ineligible for generalisation. However, we are not going to learn any new constraints on alpha, -because its kind isn't even in scope in the outer context. So alpha -is entirely unconstrained. +because its kind isn't even in scope in the outer context (but see Wrinkle). +So alpha is entirely unconstrained. What then should we do with alpha? During generalization, every metavariable is either (A) promoted, (B) generalized, or (C) zapped @@ -1098,6 +1098,17 @@ We do this eager zapping in candidateQTyVars, which always precedes generalisation, because at that moment we have a clear picture of what skolems are in scope. +Wrinkle: + +We must make absolutely sure that alpha indeed is not +from an outer context. (Otherwise, we might indeed learn more information +about it.) This can be done easily: we just check alpha's TcLevel. +That level must be strictly greater than the ambient TcLevel in order +to treat it as naughty. We say "strictly greater than" because the call to +candidateQTyVars is made outside the bumped TcLevel, as stated in the +comment to candidateQTyVarsOfType. The level check is done in go_tv +in collect_cant_qtvs. Skipping this check caused #16517. + -} data CandidatesQTvs @@ -1145,13 +1156,17 @@ candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind. +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -- See Note [CandidatesQTvs determinism and order] -- See Note [Dependent type variables] candidateQTyVarsOfType :: TcType -- not necessarily zonked -> TcM CandidatesQTvs candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty --- | Like 'splitDepVarsOfType', but over a list of types +-- | Like 'candidateQTyVarsOfType', but over a list of types +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys @@ -1175,7 +1190,7 @@ delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars collect_cand_qtvs :: Bool -- True <=> consider every fv in Type to be dependent - -> VarSet -- Bound variables (both locally bound and globally bound) + -> VarSet -- Bound variables (locals only) -> CandidatesQTvs -- Accumulating parameter -> Type -- Not necessarily zonked -> TcM CandidatesQTvs @@ -1220,16 +1235,26 @@ collect_cand_qtvs is_dep bound dvs ty ----------------- go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | tv `elemDVarSet` kvs = return dv -- We have met this tyvar aleady + | tv `elemDVarSet` kvs + = return dv -- We have met this tyvar aleady + | not is_dep - , tv `elemDVarSet` tvs = return dv -- We have met this tyvar aleady + , tv `elemDVarSet` tvs + = return dv -- We have met this tyvar aleady + | otherwise = do { tv_kind <- zonkTcType (tyVarKind tv) -- This zonk is annoying, but it is necessary, both to -- ensure that the collected candidates have zonked kinds -- (Trac #15795) and to make the naughty check -- (which comes next) works correctly - ; if intersectsVarSet bound (tyCoVarsOfType tv_kind) + + ; cur_lvl <- getTcLevel + ; if tcTyVarLevel tv `strictlyDeeperThan` cur_lvl && + -- this tyvar is from an outer context: see Wrinkle + -- in Note [Naughty quantification candidates] + + intersectsVarSet bound (tyCoVarsOfType tv_kind) then -- See Note [Naughty quantification candidates] do { traceTc "Zapping naughty quantifier" (pprTyVar tv) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 36ec8dcd2e..f6f9e26836 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -61,7 +61,6 @@ import RnExpr import RnUtils ( HsDocContext(..) ) import RnFixity ( lookupFixityRn ) import MkId -import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags @@ -2427,12 +2426,13 @@ tcRnType hsc_env normalise rdr_type -- It can have any rank or kind -- First bring into scope any wildcards ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; ((ty, kind), lie) <- - captureConstraints $ + ; (ty, kind) <- pushTcLevelM_ $ + -- must push level to satisfy level precondition of + -- kindGeneralize, below + solveEqualities $ tcWildCardBinders wcs $ \ wcs' -> do { emitWildCardHoleConstraints wcs' ; tcLHsTypeUnsaturated rn_type } - ; _ <- checkNoErrs (simplifyInteractive lie) -- Do kind generalisation; see Note [Kind-generalise in tcRnType] ; kind <- zonkTcType kind @@ -2549,7 +2549,9 @@ tcRnDeclsi hsc_env local_decls externaliseAndTidyId :: Module -> Id -> TcM Id externaliseAndTidyId this_mod id = do { name' <- externaliseName this_mod (idName id) - ; return (globaliseAndTidyId (setIdName id name')) } + ; return $ globaliseId id + `setIdName` name' + `setIdType` tidyTopType (idType id) } {- diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 7c9d70e066..ccf2d0d10f 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2095,6 +2095,16 @@ see dropDerivedWC. For example [D] Int ~ Bool, and we don't want to report that because it's incomprehensible. That is why we don't rewrite wanteds with wanteds! + * We might float out some Wanteds from an implication, leaving behind + their insoluble Deriveds. For example: + + forall a[2]. [W] alpha[1] ~ Int + [W] alpha[1] ~ Bool + [D] Int ~ Bool + + The Derived is insoluble, but we very much want to drop it when floating + out. + But (tiresomely) we do keep *some* Derived constraints: * Type holes are derived constraints, because they have no evidence @@ -2103,8 +2113,7 @@ But (tiresomely) we do keep *some* Derived constraints: * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with KindEqOrigin, may arise from a type equality a ~ Int#, say. See Note [Equalities with incompatible kinds] in TcCanonical. - These need to be kept because the kind equalities might have different - source locations and hence different error messages. + Keeping these around produces better error messages, in practice. E.g., test case dependent/should_fail/T11471 * We keep most derived equalities arising from functional dependencies diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index bda9b77a9b..838fb78c2e 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -152,8 +152,26 @@ solveLocalEqualities :: String -> TcM a -> TcM a solveLocalEqualities callsite thing_inside = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside ; emitConstraints wanted + + -- See Note [Fail fast if there are insoluble kind equalities] + ; when (insolubleWC wanted) $ + failM + ; return res } +{- Note [Fail fast if there are insoluble kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather like in simplifyInfer, fail fast if there is an insoluble +constraint. Otherwise we'll just succeed in kind-checking a nonsense +type, with a cascade of follow-up errors. + +For example polykinds/T12593, T15577, and many others. + +Take care to ensure that you emit the insoluble constraints before +failing, because they are what will ulimately lead to the error +messsage! +-} + solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) solveLocalEqualitiesX callsite thing_inside = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 7bf5e20431..edb91b88bc 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1038,9 +1038,11 @@ kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM_ kc_sig) sigs } where - kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty + kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty kc_sig _ = return () + skol_info = TyConSkol ClassFlavour name + kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index b2c9b3291f..c4cc25e499 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -516,6 +516,17 @@ superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely disti -- The choice of level number here is a bit dodgy, but -- topTcLevel works in the places that vanillaSkolemTv is used +instance Outputable TcTyVarDetails where + ppr = pprTcTyVarDetails + +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +-- For debugging +pprTcTyVarDetails (RuntimeUnk {}) = text "rt" +pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl +pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) + = ppr info <> colon <> ppr tclvl + ----------------------------- data MetaDetails = Flexi -- Flexi type variables unify to become Indirects @@ -544,20 +555,11 @@ instance Outputable MetaDetails where ppr Flexi = text "Flexi" ppr (Indirect ty) = text "Indirect" <+> ppr ty -pprTcTyVarDetails :: TcTyVarDetails -> SDoc --- For debugging -pprTcTyVarDetails (RuntimeUnk {}) = text "rt" -pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl -pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl -pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) - = pp_info <> colon <> ppr tclvl - where - pp_info = case info of - TauTv -> text "tau" - TyVarTv -> text "tyv" - FlatMetaTv -> text "fmv" - FlatSkolTv -> text "fsk" - +instance Outputable MetaInfo where + ppr TauTv = text "tau" + ppr TyVarTv = text "tyv" + ppr FlatMetaTv = text "fmv" + ppr FlatSkolTv = text "fsk" {- ********************************************************************* * * @@ -795,10 +797,10 @@ checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) = ctxt_tclvl >= tv_tclvl +-- Returns topTcLevel for non-TcTyVars tcTyVarLevel :: TcTyVar -> TcLevel tcTyVarLevel tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl SkolemTv tv_lvl _ -> tv_lvl RuntimeUnk -> topTcLevel diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 1fe2c68ae0..2f480f97d2 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -19,6 +19,7 @@ import TyCoRep( Type(..), TyLit(..) ) import TcEnv import TcEvidence ( mkWpTyApps ) import TcRnMonad +import TcTypeableValidity import HscTypes ( lookupId ) import PrelNames import TysPrim ( primTyCons ) @@ -43,7 +44,6 @@ import FastString ( FastString, mkFastString, fsLit ) import Control.Monad.Trans.State import Control.Monad.Trans.Class (lift) -import Data.Maybe ( isJust ) import Data.Word( Word64 ) {- Note [Grand plan for Typeable] @@ -410,36 +410,6 @@ mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..}) tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs return $ unitBag tycon_rep_bind --- | Here is where we define the set of Typeable types. These exclude type --- families and polytypes. -tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && typeIsTypeable (dropForAlls $ tyConKind tc) - -- Ensure that the kind of the TyCon, with its initial foralls removed, - -- is representable (e.g. has no higher-rank polymorphism or type - -- synonyms). - --- | Is a particular 'Type' representable by @Typeable@? Here we look for --- polytypes and types containing casts (which may be, for instance, a type --- family). -typeIsTypeable :: Type -> Bool --- We handle types of the form (TYPE rep) specifically to avoid --- looping on (tyConIsTypeable RuntimeRep) -typeIsTypeable ty - | Just ty' <- coreView ty = typeIsTypeable ty' -typeIsTypeable ty - | isJust (kindRep_maybe ty) = True -typeIsTypeable (TyVarTy _) = True -typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b -typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b -typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc - && all typeIsTypeable args -typeIsTypeable (ForAllTy{}) = False -typeIsTypeable (LitTy _) = True -typeIsTypeable (CastTy{}) = False -typeIsTypeable (CoercionTy{}) = False - -- | Maps kinds to 'KindRep' bindings. This binding may either be defined in -- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') -- or a binding which we generated in the current module (in which case it will diff --git a/compiler/typecheck/TcTypeableValidity.hs b/compiler/typecheck/TcTypeableValidity.hs new file mode 100644 index 0000000000..df3e252299 --- /dev/null +++ b/compiler/typecheck/TcTypeableValidity.hs @@ -0,0 +1,46 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + +-- | This module is separate from "TcTypeable" because the functions in this +-- module are used in "ClsInst", and importing "TcTypeable" from "ClsInst" +-- would lead to an import cycle. +module TcTypeableValidity (tyConIsTypeable, typeIsTypeable) where + +import GhcPrelude + +import TyCoRep +import TyCon +import Type + +import Data.Maybe (isJust) + +-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type +-- families and polytypes. +tyConIsTypeable :: TyCon -> Bool +tyConIsTypeable tc = + isJust (tyConRepName_maybe tc) + && typeIsTypeable (dropForAlls $ tyConKind tc) + +-- | Is a particular 'Type' representable by @Typeable@? Here we look for +-- polytypes and types containing casts (which may be, for instance, a type +-- family). +typeIsTypeable :: Type -> Bool +-- We handle types of the form (TYPE LiftedRep) specifically to avoid +-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) +-- to be typeable without inspecting rr, but this exhibits bad behavior +-- when rr is a type family. +typeIsTypeable ty + | Just ty' <- coreView ty = typeIsTypeable ty' +typeIsTypeable ty + | isLiftedTypeKind ty = True +typeIsTypeable (TyVarTy _) = True +typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b +typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b +typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc + && all typeIsTypeable args +typeIsTypeable (ForAllTy{}) = False +typeIsTypeable (LitTy _) = True +typeIsTypeable (CastTy{}) = False +typeIsTypeable (CoercionTy{}) = False diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index c45aa7cccd..29f9fc5c2b 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -14,7 +14,7 @@ module InstEnv ( OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, - instanceDFunId, tidyClsInstDFun, instanceRoughTcs, + instanceDFunId, updateClsInstDFun, instanceRoughTcs, fuzzyClsInstCmp, orphNamesOfClsInst, InstEnvs(..), VisibleOrphanModules, InstEnv, @@ -199,8 +199,8 @@ being equal to instanceDFunId :: ClsInst -> DFunId instanceDFunId = is_dfun -tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst -tidyClsInstDFun tidy_dfun ispec +updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +updateClsInstDFun tidy_dfun ispec = ispec { is_dfun = tidy_dfun (is_dfun ispec) } instanceRoughTcs :: ClsInst -> [Maybe Name] diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 0a628e1a37..eac3c25e04 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -2499,39 +2499,29 @@ unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming -- environment. No CoVars, please! -zipTvSubst :: [TyVar] -> [Type] -> TCvSubst +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst zipTvSubst tvs tys - | debugIsOn - , not (all isTyVar tvs) || neLength tvs tys - = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst - | otherwise = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv where tenv = zipTyEnv tvs tys -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming -- environment. No TyVars, please! -zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst zipCvSubst cvs cos - | debugIsOn - , not (all isCoVar cvs) || neLength cvs cos - = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst - | otherwise = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv where cenv = zipCoEnv cvs cos -zipTCvSubst :: [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst zipTCvSubst tcvs tys - | debugIsOn - , neLength tcvs tys - = pprTrace "zipTCvSubst" (ppr tcvs $$ ppr tys) emptyTCvSubst - | otherwise = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst zip_tcvsubst (tv:tvs) (ty:tys) subst = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) - zip_tcvsubst _ _ subst = subst -- empty case + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! @@ -2545,8 +2535,12 @@ mkTvSubstPrs prs = and [ isTyVar tv && not (isCoercionTy ty) | (tv, ty) <- prs ] -zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars) + = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) + | otherwise = ASSERT( all (not . isCoercionTy) tys ) mkVarEnv (zipEqual "zipTyEnv" tyvars tys) -- There used to be a special case for when @@ -2562,8 +2556,13 @@ zipTyEnv tyvars tys -- -- Simplest fix is to nuke the "optimisation" -zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv -zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual "zipCoEnv" cvs cos) instance Outputable TCvSubst where ppr (TCvSubst ins tenv cenv) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index eb0b84d47e..03749e377c 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -359,13 +359,27 @@ Note [Unboxed tuple RuntimeRep vars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The contents of an unboxed tuple may have any representation. Accordingly, the kind of the unboxed tuple constructor is runtime-representation -polymorphic. For example, +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no levity polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> # - -These extra tyvars (v and w) cause some delicate processing around tuples, -where we used to be able to assume that the tycon arity and the -datacon arity were the same. Note [Injective type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 16eeea5db6..46ef0e6ab9 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -35,7 +35,7 @@ module Util ( lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, listLengthCmp, atLength, - equalLength, neLength, compareLength, leLength, ltLength, + equalLength, compareLength, leLength, ltLength, isSingleton, only, singleton, notNull, snocView, @@ -536,12 +536,6 @@ equalLength [] [] = True equalLength (_:xs) (_:ys) = equalLength xs ys equalLength _ _ = False -neLength :: [a] -> [b] -> Bool --- ^ True if length xs /= length ys -neLength [] [] = False -neLength (_:xs) (_:ys) = neLength xs ys -neLength _ _ = True - compareLength :: [a] -> [b] -> Ordering compareLength [] [] = EQ compareLength (_:xs) (_:ys) = compareLength xs ys diff --git a/configure.ac b/configure.ac index ef3efad102..fafe864bb1 100644 --- a/configure.ac +++ b/configure.ac @@ -641,7 +641,7 @@ AC_SUBST([LibtoolCmd]) # tools we are looking for. In the past, GHC supported a number of # versions of LLVM simultaneously, but that stopped working around # 3.5/3.6 release of LLVM. -LlvmVersion=7.0 +LlvmVersion=7 AC_SUBST([LlvmVersion]) sUPPORTED_LLVM_VERSION=$(echo \($LlvmVersion\) | sed 's/\./,/') AC_DEFINE_UNQUOTED([sUPPORTED_LLVM_VERSION], ${sUPPORTED_LLVM_VERSION}, [The supported LLVM version number]) diff --git a/docs/users_guide/8.8.1-notes.rst b/docs/users_guide/8.8.1-notes.rst index e315416bf3..bb8c84ead2 100644 --- a/docs/users_guide/8.8.1-notes.rst +++ b/docs/users_guide/8.8.1-notes.rst @@ -128,6 +128,11 @@ Compiler Generation of these files, which sport a ``.hie`` suffix, is enabled via the :ghc-flag:`-fwrite-ide-info` flag. See :ref:`hie-options` for more information. +LLVM backend +~~~~~~~~~~~~ + +The :ghc-flag:`LLVM backend <-fllvm>` of this release is compatible with LLVM 7. + Runtime system ~~~~~~~~~~~~~~ @@ -242,7 +247,7 @@ for further change information. libraries/binary/binary.cabal: Dependency of ``ghc`` library libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility - libraries/containers/containers.cabal: Dependency of ``ghc`` library + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library libraries/directory/directory.cabal: Dependency of ``ghc`` library libraries/filepath/filepath.cabal: Dependency of ``ghc`` library @@ -432,7 +432,7 @@ PACKAGES_STAGE1 += filepath PACKAGES_STAGE1 += array PACKAGES_STAGE1 += deepseq PACKAGES_STAGE1 += bytestring -PACKAGES_STAGE1 += containers +PACKAGES_STAGE1 += containers/containers ifeq "$(Windows_Target)" "YES" PACKAGES_STAGE1 += Win32 diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 69d317f47c..d39dd78c28 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -40,14 +40,18 @@ import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable +import OccName import DynFlags import FastString import HscTypes import SrcLoc import Module +import RdrName (mkOrig) +import PrelNames (gHC_GHCI_HELPERS) import GHCi import GHCi.RemoteTypes import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl) +import HsUtils import Util import Exception @@ -473,13 +477,12 @@ foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue) initInterpBuffering = do - nobuf <- compileGHCiExpr $ - "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++ - " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++ - " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }" - flush <- compileGHCiExpr $ - "do { System.IO.hFlush System.IO.stdout; " ++ - " System.IO.hFlush System.IO.stderr }" + let mkHelperExpr :: OccName -> Ghc ForeignHValue + mkHelperExpr occ = + GHC.compileParsedExprRemote + $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ + nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering" + flush <- mkHelperExpr $ mkVarOcc "flushAll" return (nobuf, flush) -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter @@ -502,13 +505,18 @@ turnOffBuffering_ fhv = do mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue mkEvalWrapper progname args = - compileGHCiExpr $ - "\\m -> System.Environment.withProgName " ++ show progname ++ - "(System.Environment.withArgs " ++ show args ++ " m)" - -compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue -compileGHCiExpr expr = - withTempSession mkTempSession $ GHC.compileExprRemote expr + runInternal $ GHC.compileParsedExprRemote + $ evalWrapper `GHC.mkHsApp` nlHsString progname + `GHC.mkHsApp` nlList (map nlHsString args) + where + nlHsString = nlHsLit . mkHsString + evalWrapper = + GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper") + +-- | Run a 'GhcMonad' action to compile an expression for internal usage. +runInternal :: GhcMonad m => m a -> m a +runInternal = + withTempSession mkTempSession where mkTempSession hsc_env = hsc_env { hsc_dflags = (hsc_dflags hsc_env) @@ -520,3 +528,6 @@ compileGHCiExpr expr = -- with fully qualified names without imports. `gopt_set` Opt_ImplicitImportQualified } + +compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue +compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr diff --git a/hadrian/appveyor.yml b/hadrian/appveyor.yml index 1a18abe975..b3142bd4b9 100644 --- a/hadrian/appveyor.yml +++ b/hadrian/appveyor.yml @@ -14,7 +14,7 @@ install: # Note: AppVeyor has already cloned Hadrian into c:\new-hadrian # Fetch GHC sources into c:\ghc - cd .. - - git clone --recursive git://git.haskell.org/ghc.git + - git clone --recursive git@gitlab.haskell.org:ghc/ghc.git # GHC comes with an older version of Hadrian, so we delete it - rm -rf ghc\hadrian # Copy new Hadrian into ./ghc/hadrian diff --git a/hadrian/doc/windows.md b/hadrian/doc/windows.md index 0ad2086547..faf7786015 100644 --- a/hadrian/doc/windows.md +++ b/hadrian/doc/windows.md @@ -7,9 +7,8 @@ Here is how you can build GHC, from source, on Windows. We assume that `git` and ```sh
# Get GHC and Hadrian sources; git core.autocrlf should be set to false (see Prerequisites section)
-git clone --recursive git://git.haskell.org/ghc.git
+git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
cd ghc
-git clone git://github.com/snowleopard/hadrian
# Download and install the bootstrapping GHC and MSYS2
cd hadrian
@@ -35,7 +34,7 @@ optimisations. If you need an optimised GHC, drop the `--flavour=quickest` flag the build command line (this will slow down the build to about an hour).
These are currently not the
-[official GHC building instructions](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Windows),
+[official GHC building instructions](https://gitlab.haskell.org/ghc/ghc/wikis/building/preparation/windows),
but are much simpler and may also be more robust.
The `stack build` and `stack exec hadrian` commands can be replaced by an invocation
@@ -67,4 +66,4 @@ and are also routinely tested on ## Notes
-Beware of the [current limitations of Hadrian](https://github.com/snowleopard/hadrian#current-limitations).
+Beware of the [current limitations of Hadrian](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/README.md#current-limitations).
diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index d0fe41765a..510882e447 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -53,7 +53,7 @@ checkApiAnnotations = util "check-api-annotations" checkPpr = util "check-ppr" compareSizes = util "compareSizes" `setPath` "utils/compare_sizes" compiler = top "ghc" `setPath` "compiler" -containers = lib "containers" +containers = lib "containers" `setPath` "libraries/containers/containers" deepseq = lib "deepseq" deriveConstants = util "deriveConstants" directory = lib "directory" diff --git a/hadrian/stack.yaml b/hadrian/stack.yaml index d379133384..3566a35571 100644 --- a/hadrian/stack.yaml +++ b/hadrian/stack.yaml @@ -3,22 +3,17 @@ # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) resolver: lts-12.10 +extra-deps: +# We need a newer happy (see #16825) +- git: https://github.com/simonmar/happy.git + commit: 66982277ac7aed23edbb36c5f7aa5a86e5bdf778 + # Local packages, usually specified by relative directory name packages: - '.' - '../libraries/Cabal/Cabal' - '../libraries/text' -# This is necessary to build until happy's version bounds are updated to work -# with the new Cabal version. Stack's error message explains the issue: -# -# In the dependencies for happy-1.19.9: -# Cabal-2.3.0.0 from stack configuration does not match <2.2 (latest matching version is 2.0.1.1) -# needed due to hadrian-0.1.0.0 -> happy-1.19.9 -# -# TODO: Remove this once it's no longer necessary -allow-newer: true - nix: enable: false packages: diff --git a/includes/Cmm.h b/includes/Cmm.h index 7334eab8c1..ede77f0c00 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -303,7 +303,9 @@ #define ENTER_(ret,x) \ again: \ W_ info; \ - LOAD_INFO(ret,x) \ + LOAD_INFO(ret,x) \ + /* See Note [Heap memory barriers] in SMP.h */ \ + prim_read_barrier; \ switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \ (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { \ case \ @@ -626,6 +628,14 @@ #define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */ #endif +// Memory barriers. +// For discussion of how these are used to fence heap object +// accesses see Note [Heap memory barriers] in SMP.h. +#if defined(THREADED_RTS) +#define prim_read_barrier prim %read_barrier() +#else +#define prim_read_barrier /* nothing */ +#endif #if defined(THREADED_RTS) #define prim_write_barrier prim %write_barrier() #else diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h index 4020aef0d9..db6b4b954a 100644 --- a/includes/stg/SMP.h +++ b/includes/stg/SMP.h @@ -96,6 +96,151 @@ EXTERN_INLINE void write_barrier(void); EXTERN_INLINE void store_load_barrier(void); EXTERN_INLINE void load_load_barrier(void); +/* + * Note [Heap memory barriers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * + * Machines with weak memory ordering semantics have consequences for how + * closures are observed and mutated. For example, consider a thunk that needs + * to be updated to an indirection. In order for the indirection to be safe for + * concurrent observers to enter, said observers must read the indirection's + * info table before they read the indirectee. Furthermore, the indirectee must + * be set before the info table pointer. This ensures that if the observer sees + * an IND info table then the indirectee is valid. + * + * When a closure is updated with an indirection, both its info table and its + * indirectee must be written. With weak memory ordering, these two writes can + * be arbitrarily reordered, and perhaps even interleaved with other threads' + * reads and writes (in the absence of memory barrier instructions). Consider + * this example of a bad reordering: + * + * - An updater writes to a closure's info table (INFO_TYPE is now IND). + * - A concurrent observer branches upon reading the closure's INFO_TYPE as IND. + * - A concurrent observer reads the closure's indirectee and enters it. + * - An updater writes the closure's indirectee. + * + * Here the update to the indirectee comes too late and the concurrent observer + * has jumped off into the abyss. Speculative execution can also cause us + * issues, consider: + * + * - an observer is about to case on a value in closure's info table. + * - the observer speculatively reads one or more of closure's fields. + * - an updater writes to closure's info table. + * - the observer takes a branch based on the new info table value, but with the + * old closure fields! + * - the updater writes to the closure's other fields, but its too late. + * + * Because of these effects, reads and writes to a closure's info table must be + * ordered carefully with respect to reads and writes to the closure's other + * fields, and memory barriers must be placed to ensure that reads and writes + * occur in program order. Specifically, updates to an already existing closure + * must follow the following pattern: + * + * - Update the closure's (non-info table) fields. + * - Write barrier. + * - Update the closure's info table. + * + * Observing the fields of an updateable closure (e.g. a THUNK) must follow the + * following pattern: + * + * - Read the closure's info pointer. + * - Read barrier. + * - Read the closure's (non-info table) fields. + * + * We must also take care when we expose a newly-allocated closure to other cores + * by writing a pointer to it to some shared data structure (e.g. an MVar#, a Message, + * or MutVar#). Specifically, we need to ensure that all writes constructing the + * closure are visible *before* the write exposing the new closure is made visible: + * + * - Allocate memory for the closure + * - Write the closure's info pointer and fields (ordering betweeen this doesn't + * matter since the closure isn't yet visible to anyone else). + * - Write barrier + * - Make closure visible to other cores + * + * Note that thread stacks are inherently thread-local and consequently allocating an + * object and introducing a reference to it to our stack needs no barrier. + * + * There are several ways in which the mutator may make a newly-allocated + * closure visible to other cores: + * + * - Eager blackholing a THUNK: + * This is protected by an explicit write barrier in the eager blackholing + * code produced by the codegen. See StgCmmBind.emitBlackHoleCode. + * + * - Lazy blackholing a THUNK: + * This is is protected by an explicit write barrier in the thread suspension + * code. See ThreadPaused.c:threadPaused. + * + * - Updating a BLACKHOLE: + * This case is protected by explicit write barriers in the the update frame + * entry code (see rts/Updates.h). + * + * - Blocking on an MVar# (e.g. takeMVar#): + * In this case the appropriate MVar primops (e.g. stg_takeMVarzh). include + * explicit memory barriers to ensure that the the newly-allocated + * MVAR_TSO_QUEUE is visible to other cores. + * + * - Write to an MVar# (e.g. putMVar#): + * This protected by the full barrier implied by the CAS in putMVar#. + * + * - Write to a TVar#: + * This is protected by the full barrier implied by the CAS in STM.c:lock_stm. + * + * - Write to an Array#, ArrayArray#, or SmallArray#: + * This case is protected by an explicit write barrier in the code produced + * for this primop by the codegen. See StgCmmPrim.doWritePtrArrayOp and + * StgCmmPrim.doWriteSmallPtrArrayOp. Relevant issue: #12469. + * + * - Write to MutVar# via writeMutVar#: + * This case is protected by an explicit write barrier in the code produced + * for this primop by the codegen. + * + * - Write to MutVar# via atomicModifyMutVar# or casMutVar#: + * This is protected by the full barrier implied by the cmpxchg operations + * in this primops. + * + * - Sending a Message to another capability: + * This is protected by the acquition and release of the target capability's + * lock in Messages.c:sendMessage. + * + * Finally, we must ensure that we flush all cores store buffers before + * entering and leaving GC, since stacks may be read by other cores. This + * happens as a side-effect of taking and release mutexes (which implies + * acquire and release barriers, respectively). + * + * N.B. recordClosureMutated places a reference to the mutated object on + * the capability-local mut_list. Consequently this does not require any memory + * barrier. + * + * During parallel GC we need to be careful during evacuation: before replacing + * a closure with a forwarding pointer we must commit a write barrier to ensure + * that the copy we made in to-space is visible to other cores. + * + * However, we can be a bit lax when *reading* during GC. Specifically, the GC + * can only make a very limited set of changes to existing closures: + * + * - it can replace a closure's info table with stg_WHITEHOLE. + * - it can replace a previously-whitehole'd closure's info table with a + * forwarding pointer + * - it can replace a previously-whitehole'd closure's info table with a + * valid info table pointer (done in eval_thunk_selector) + * - it can update the value of a pointer field after evacuating it + * + * This is quite nice since we don't need to worry about an interleaving + * of writes producing an invalid state: a closure's fields remain valid after + * an update of its info table pointer and vice-versa. + * + * After a round of parallel scavenging we must also ensure that any writes the + * GC thread workers made are visible to the main GC thread. This is ensured by + * the full barrier implied by the atomic decrement in + * GC.c:scavenge_until_all_done. + * + * The work-stealing queue (WSDeque) also requires barriers; these are + * documented in WSDeque.c. + * + */ + /* ---------------------------------------------------------------------------- Implementations ------------------------------------------------------------------------- */ diff --git a/libraries/base/GHC/GHCi/Helpers.hs b/libraries/base/GHC/GHCi/Helpers.hs new file mode 100644 index 0000000000..de510f3674 --- /dev/null +++ b/libraries/base/GHC/GHCi/Helpers.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.GHCi.Helpers +-- Copyright : (c) The GHC Developers +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Various helpers used by the GHCi shell. +-- +----------------------------------------------------------------------------- + +module GHC.GHCi.Helpers + ( disableBuffering, flushAll + , evalWrapper + ) where + +import System.IO +import System.Environment + +disableBuffering :: IO () +disableBuffering = do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + +flushAll :: IO () +flushAll = do + hFlush stdout + hFlush stderr + +evalWrapper :: String -> [String] -> IO a -> IO a +evalWrapper progName args m = + withProgName progName (withArgs args m) diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs index 7e3e514be9..449fc20425 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -105,6 +105,9 @@ someNatVal n -- @since 4.7.0.0 someSymbolVal :: String -> SomeSymbol someSymbolVal n = withSSymbol SomeSymbol (SSymbol n) Proxy +{-# NOINLINE someSymbolVal #-} +-- For details see Note [NOINLINE someNatVal] in "GHC.TypeNats" +-- The issue described there applies to `someSymbolVal` as well. -- | @since 4.7.0.0 instance Eq SomeSymbol where diff --git a/libraries/base/GHC/TypeNats.hs b/libraries/base/GHC/TypeNats.hs index b78608af89..48428cb903 100644 --- a/libraries/base/GHC/TypeNats.hs +++ b/libraries/base/GHC/TypeNats.hs @@ -78,6 +78,65 @@ data SomeNat = forall n. KnownNat n => SomeNat (Proxy n) -- @since 4.10.0.0 someNatVal :: Natural -> SomeNat someNatVal n = withSNat SomeNat (SNat n) Proxy +{-# NOINLINE someNatVal #-} -- See Note [NOINLINE someNatVal] + +{- Note [NOINLINE someNatVal] + +`someNatVal` converts a natural number to an existentially quantified +dictionary for `KnowNat` (aka `SomeNat`). The existential quantification +is very important, as it captures the fact that we don't know the type +statically, although we do know that it exists. Because this type is +fully opaque, we should never be able to prove that it matches anything else. +This is why coherence should still hold: we can manufacture a `KnownNat k` +dictionary, but it can never be confused with a `KnownNat 33` dictionary, +because we should never be able to prove that `k ~ 33`. + +But how to implement `someNatVal`? We can't quite implement it "honestly" +because `SomeNat` needs to "hide" the type of the newly created dictionary, +but we don't know what the actual type is! If `someNatVal` was built into +the language, then we could manufacture a new skolem constant, +which should behave correctly. + +Since extra language constructors have additional maintenance costs, +we use a trick to implement `someNatVal` in the library. The idea is that +instead of generating a "fresh" type for each use of `someNatVal`, we simply +use GHC's placeholder type `Any` (of kind `Nat`). So, the elaborated +version of the code is: + + someNatVal n = withSNat @T (SomeNat @T) (SNat @T n) (Proxy @T) + where type T = Any Nat + +After inlining and simplification, this ends up looking something like this: + + someNatVal n = SomeNat @T (KnownNat @T (SNat @T n)) (Proxy @T) + where type T = Any Nat + +`KnownNat` is the constructor for dictionaries for the class `KnownNat`. +See Note [magicDictId magic] in "basicType/MkId.hs" for details on how +we actually construct the dictionry. + +Note that using `Any Nat` is not really correct, as multilple calls to +`someNatVal` would violate coherence: + + type T = Any Nat + + x = SomeNat @T (KnownNat @T (SNat @T 1)) (Proxy @T) + y = SomeNat @T (KnownNat @T (SNat @T 2)) (Proxy @T) + +Note that now the code has two dictionaries with the same type, `KnownNat Any`, +but they have different implementations, namely `SNat 1` and `SNat 2`. This +is not good, as GHC assumes coherence, and it is free to interchange +dictionaries of the same type, but in this case this would produce an incorrect +result. See #16586 for examples of this happening. + +We can avoid this problem by making the definition of `someNatVal` opaque +and we do this by using a `NOINLINE` pragma. This restores coherence, because +GHC can only inspect the result of `someNatVal` by pattern matching on the +existential, which would generate a new type. This restores correctness, +at the cost of having a little more allocation for the `SomeNat` constructors. +-} + + -- | @since 4.7.0.0 instance Eq SomeNat where diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc index 095b25c236..0e7c9fd454 100644 --- a/libraries/base/System/Environment/ExecutablePath.hsc +++ b/libraries/base/System/Environment/ExecutablePath.hsc @@ -32,6 +32,14 @@ import System.Posix.Internals import Foreign.C import Foreign.Marshal.Array import System.Posix.Internals +#elif defined(freebsd_HOST_OS) +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#include <sys/sysctl.h> #elif defined(mingw32_HOST_OS) import Control.Exception import Data.List @@ -132,6 +140,45 @@ readSymbolicLink file = getExecutablePath = readSymbolicLink $ "/proc/self/exe" -------------------------------------------------------------------------------- +-- FreeBSD + +#elif defined(freebsd_HOST_OS) + +foreign import ccall unsafe "sysctl" + c_sysctl + :: Ptr CInt -- MIB + -> CUInt -- MIB size + -> Ptr CChar -- old / current value buffer + -> Ptr CSize -- old / current value buffer size + -> Ptr CChar -- new value + -> CSize -- new value size + -> IO CInt -- result + +getExecutablePath = do + withArrayLen mib $ \n mibPtr -> do + let mibLen = fromIntegral n + alloca $ \bufSizePtr -> do + status <- c_sysctl mibPtr mibLen nullPtr bufSizePtr nullPtr 0 + case status of + 0 -> do + reqBufSize <- fromIntegral <$> peek bufSizePtr + allocaBytes reqBufSize $ \buf -> do + newStatus <- c_sysctl mibPtr mibLen buf bufSizePtr nullPtr 0 + case newStatus of + 0 -> peekFilePath buf + _ -> barf + _ -> barf + where + barf = throwErrno "getExecutablePath" + mib = + [ (#const CTL_KERN) + , (#const KERN_PROC) + , (#const KERN_PROC_PATHNAME) + , -1 -- current process + ] + + +-------------------------------------------------------------------------------- -- Windows #elif defined(mingw32_HOST_OS) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index a2c91641f4..66a8ab284b 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -41,7 +41,7 @@ extra-source-files: source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/base Flag integer-simple @@ -230,6 +230,7 @@ Library GHC.Foreign GHC.ForeignPtr GHC.GHCi + GHC.GHCi.Helpers GHC.Generics GHC.IO GHC.IO.Buffer diff --git a/libraries/base/tests/T16111.hs b/libraries/base/tests/T16111.hs new file mode 100644 index 0000000000..241714ea13 --- /dev/null +++ b/libraries/base/tests/T16111.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import Data.Bits +import Data.Word + +main :: IO () +main = print $ toInteger (shiftL 1 hm :: Word64) + == toInteger (shiftL 1 hm :: Word64) + +hm :: Int +hm = -1 +{-# NOINLINE hm #-} + diff --git a/libraries/base/tests/T16111.stderr b/libraries/base/tests/T16111.stderr new file mode 100644 index 0000000000..7562f9de58 --- /dev/null +++ b/libraries/base/tests/T16111.stderr @@ -0,0 +1,2 @@ +T16111: arithmetic overflow + diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 9cb9c958fb..4ef2f07dd2 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -233,3 +233,4 @@ test('T10412', normal, compile_and_run, ['']) test('T13896', normal, compile_and_run, ['']) test('T13167', fragile_for(16536, ['threaded2']), compile_and_run, ['']) test('T15349', [exit_code(1), expect_broken_for(15349, 'ghci')], compile_and_run, ['']) +test('T16111', exit_code(1), compile_and_run, ['']) diff --git a/libraries/containers b/libraries/containers -Subproject 03dcb287c96613ceb1f64d5d5a82f7b94b87926 +Subproject aaeda192b34a66b1c5359a85271adf8fed26dd1 diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 2c06a74df9..11460a1f86 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -139,4 +139,4 @@ data Extension | NumericUnderscores | QuantifiedConstraints | StarIsType - deriving (Eq, Enum, Show, Generic) + deriving (Eq, Enum, Show, Generic, Bounded) diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal.in b/libraries/ghc-boot-th/ghc-boot-th.cabal.in index 657055d93d..a25fae47d3 100644 --- a/libraries/ghc-boot-th/ghc-boot-th.cabal.in +++ b/libraries/ghc-boot-th/ghc-boot-th.cabal.in @@ -23,7 +23,7 @@ extra-source-files: changelog.md source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghc-boot-th Library diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in index 863987beab..7aba94246c 100644 --- a/libraries/ghc-boot/ghc-boot.cabal.in +++ b/libraries/ghc-boot/ghc-boot.cabal.in @@ -28,7 +28,7 @@ extra-source-files: changelog.md source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghc-boot Library diff --git a/libraries/ghc-compact/ghc-compact.cabal b/libraries/ghc-compact/ghc-compact.cabal index d7572ff11a..43e67b8642 100644 --- a/libraries/ghc-compact/ghc-compact.cabal +++ b/libraries/ghc-compact/ghc-compact.cabal @@ -25,7 +25,7 @@ tested-with: GHC==7.11 source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghc-compact library diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in index 386c984222..9611e81d56 100644 --- a/libraries/ghc-heap/ghc-heap.cabal.in +++ b/libraries/ghc-heap/ghc-heap.cabal.in @@ -16,7 +16,7 @@ tested-with: GHC==7.11 source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghc-heap library diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index a95f1ecaa8..7c1efb01b5 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -16,7 +16,7 @@ extra-source-files: changelog.md source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghc-prim custom-setup diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index 4b8100b9e2..967c296899 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -24,7 +24,7 @@ Flag ghci source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghci library @@ -56,6 +56,8 @@ library GHCi.Signals GHCi.TH + include-dirs: @FFIIncludeDir@ + exposed-modules: GHCi.BreakArray GHCi.BinaryArray diff --git a/libraries/integer-simple/integer-simple.cabal b/libraries/integer-simple/integer-simple.cabal index 96c2e2358e..08e3acdc0f 100644 --- a/libraries/integer-simple/integer-simple.cabal +++ b/libraries/integer-simple/integer-simple.cabal @@ -12,7 +12,7 @@ build-type: Simple source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/integer-simple Library diff --git a/libraries/parsec b/libraries/parsec -Subproject 3fafb06cf1af74d0c877da6948af3c2bffd0f2b +Subproject 60dfb0cb6a711f141e5d8728af37de894e33795 diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal index ecd42a6d97..3c5bb31021 100644 --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -20,7 +20,7 @@ extra-source-files: changelog.md source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/template-haskell Library diff --git a/llvm-targets b/llvm-targets index db35131493..d62e069cdf 100644 --- a/llvm-targets +++ b/llvm-targets @@ -14,6 +14,7 @@ ,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) +,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt")) ,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", "")) diff --git a/rts/Apply.cmm b/rts/Apply.cmm index 0454fd69e2..7d87d4dd75 100644 --- a/rts/Apply.cmm +++ b/rts/Apply.cmm @@ -62,6 +62,8 @@ again: W_ info; P_ untaggedfun; W_ arity; + // We must obey the correct heap object observation pattern in + // Note [Heap memory barriers] in SMP.h. untaggedfun = UNTAG(fun); info = %INFO_PTR(untaggedfun); switch [INVALID_OBJECT .. N_CLOSURE_TYPES] diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c index 473e510f5e..f4ecd71ad8 100644 --- a/rts/CheckUnload.c +++ b/rts/CheckUnload.c @@ -404,6 +404,7 @@ void checkUnload (StgClosure *static_objects) p = UNTAG_STATIC_LIST_PTR(p); checkAddress(addrs, p, s_indices); info = get_itbl(p); + checkAddress(addrs, info, s_indices); link = *STATIC_LINK(info, p); } diff --git a/rts/Compact.cmm b/rts/Compact.cmm index 061646846d..bae94a03cd 100644 --- a/rts/Compact.cmm +++ b/rts/Compact.cmm @@ -53,6 +53,9 @@ import CLOSURE base_GHCziIOziException_cannotCompactPinned_closure; // data structure. It takes the location to store the address of the // compacted object as an argument, so that it can be tail-recursive. // +// N.B. No memory barrier (see Note [Heap memory barriers] in SMP.h) is needed +// here since this is essentially an allocation of a new object which won't +// be visible to other cores until after we return. stg_compactAddWorkerzh ( P_ compact, // The Compact# object P_ p, // The object to compact diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 3450780ba5..2d68a1ce3a 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -266,7 +266,6 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap) uint32_t size = PAP_sizeW(oldpap->n_args); StgPAP *pap = (StgPAP *)allocate(cap, size); enterFunCCS(&cap->r, oldpap->header.prof.ccs); - SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS); pap->arity = oldpap->arity; pap->n_args = oldpap->n_args; pap->fun = oldpap->fun; @@ -274,6 +273,8 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap) for (i = 0; i < ((StgPAP *)pap)->n_args; i++) { pap->payload[i] = oldpap->payload[i]; } + // No write barrier is needed here as this is a new allocation + SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS); return (StgClosure *)pap; } @@ -799,7 +800,6 @@ do_apply: // build a new PAP and return it. StgPAP *new_pap; new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m)); - SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS); new_pap->arity = pap->arity - n; new_pap->n_args = pap->n_args + m; new_pap->fun = pap->fun; @@ -809,6 +809,8 @@ do_apply: for (i = 0; i < m; i++) { new_pap->payload[pap->n_args + i] = (StgClosure *)SpW(i); } + // No write barrier is needed here as this is a new allocation + SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS); tagged_obj = (StgClosure *)new_pap; Sp_addW(m); goto do_return; @@ -844,13 +846,14 @@ do_apply: StgPAP *pap; uint32_t i; pap = (StgPAP *)allocate(cap, PAP_sizeW(m)); - SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS); pap->arity = arity - n; pap->fun = obj; pap->n_args = m; for (i = 0; i < m; i++) { pap->payload[i] = (StgClosure *)SpW(i); } + // No write barrier is needed here as this is a new allocation + SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS); tagged_obj = (StgClosure *)pap; Sp_addW(m); goto do_return; @@ -1081,7 +1084,6 @@ run_BCO: // the BCO size_words = BCO_BITMAP_SIZE(obj) + 2; new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words)); - SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS); new_aps->size = size_words; new_aps->fun = &stg_dummy_ret_closure; @@ -1095,6 +1097,9 @@ run_BCO: new_aps->payload[i] = (StgClosure *)SpW(i-2); } + // No write barrier is needed here as this is a new allocation + SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS); + // Arrange the stack to call the breakpoint IO action, and // continue execution of this BCO when the IO action returns. // @@ -1423,6 +1428,8 @@ run_BCO: ap = (StgAP*)allocate(cap, AP_sizeW(n_payload)); SpW(-1) = (W_)ap; ap->n_args = n_payload; + // No write barrier is needed here as this is a new allocation + // visible only from our stack SET_HDR(ap, &stg_AP_info, cap->r.rCCCS) Sp_subW(1); goto nextInsn; @@ -1434,6 +1441,8 @@ run_BCO: ap = (StgAP*)allocate(cap, AP_sizeW(n_payload)); SpW(-1) = (W_)ap; ap->n_args = n_payload; + // No write barrier is needed here as this is a new allocation + // visible only from our stack SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS) Sp_subW(1); goto nextInsn; @@ -1447,6 +1456,8 @@ run_BCO: SpW(-1) = (W_)pap; pap->n_args = n_payload; pap->arity = arity; + // No write barrier is needed here as this is a new allocation + // visible only from our stack SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS) Sp_subW(1); goto nextInsn; @@ -1522,12 +1533,14 @@ run_BCO: itbl->layout.payload.nptrs ); StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request); ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0); - SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS); for (i = 0; i < n_words; i++) { con->payload[i] = (StgClosure*)SpW(i); } Sp_addW(n_words); Sp_subW(1); + // No write barrier is needed here as this is a new allocation + // visible only from our stack + SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS); SpW(0) = (W_)con; IF_DEBUG(interpreter, debugBelch("\tBuilt "); diff --git a/rts/Linker.c b/rts/Linker.c index ac030af837..7f6c816e98 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1183,11 +1183,17 @@ void freeObjectCode (ObjectCode *oc) oc->sections[i].mapped_size); break; case SECTION_M32: + IF_DEBUG(sanity, + memset(oc->sections[i].start, + 0x00, oc->sections[i].size)); m32_free(oc->sections[i].start, oc->sections[i].size); break; #endif case SECTION_MALLOC: + IF_DEBUG(sanity, + memset(oc->sections[i].start, + 0x00, oc->sections[i].size)); stgFree(oc->sections[i].start); break; default: diff --git a/rts/Messages.c b/rts/Messages.c index 2b13b6306c..d878db5eda 100644 --- a/rts/Messages.c +++ b/rts/Messages.c @@ -173,6 +173,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) "blackhole %p", (W_)msg->tso->id, msg->bh); info = bh->header.info; + load_load_barrier(); // See Note [Heap memory barriers] in SMP.h // If we got this message in our inbox, it might be that the // BLACKHOLE has already been updated, and GC has shorted out the @@ -196,6 +197,7 @@ loop: // and turns this into an infinite loop. p = UNTAG_CLOSURE((StgClosure*)VOLATILE_LOAD(&((StgInd*)bh)->indirectee)); info = p->header.info; + load_load_barrier(); // See Note [Heap memory barriers] in SMP.h if (info == &stg_IND_info) { @@ -226,7 +228,6 @@ loop: bq = (StgBlockingQueue*)allocate(cap, sizeofW(StgBlockingQueue)); // initialise the BLOCKING_QUEUE object - SET_HDR(bq, &stg_BLOCKING_QUEUE_DIRTY_info, CCS_SYSTEM); bq->bh = bh; bq->queue = msg; bq->owner = owner; @@ -238,6 +239,11 @@ loop: // a collision to update a BLACKHOLE and a BLOCKING_QUEUE // becomes orphaned (see updateThunk()). bq->link = owner->bq; + SET_HDR(bq, &stg_BLOCKING_QUEUE_DIRTY_info, CCS_SYSTEM); + // We are about to make the newly-constructed message visible to other cores; + // a barrier is necessary to ensure that all writes are visible. + // See Note [Heap memory barriers] in SMP.h. + write_barrier(); owner->bq = bq; dirty_TSO(cap, owner); // we modified owner->bq @@ -255,7 +261,7 @@ loop: } // point to the BLOCKING_QUEUE from the BLACKHOLE - write_barrier(); // make the BQ visible + write_barrier(); // make the BQ visible, see Note [Heap memory barriers]. ((StgInd*)bh)->indirectee = (StgClosure *)bq; recordClosureMutated(cap,bh); // bh was mutated @@ -286,10 +292,14 @@ loop: msg->link = bq->queue; bq->queue = msg; + // No barrier is necessary here: we are only exposing the + // closure to the GC. See Note [Heap memory barriers] in SMP.h. recordClosureMutated(cap,(StgClosure*)msg); if (info == &stg_BLOCKING_QUEUE_CLEAN_info) { bq->header.info = &stg_BLOCKING_QUEUE_DIRTY_info; + // No barrier is necessary here: we are only exposing the + // closure to the GC. See Note [Heap memory barriers] in SMP.h. recordClosureMutated(cap,(StgClosure*)bq); } diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 625f5f5ab3..27851c0d5a 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -105,6 +105,7 @@ stg_newPinnedByteArrayzh ( W_ n ) to BA_ALIGN bytes: */ p = p + ((-p - SIZEOF_StgArrBytes) & BA_MASK); + /* No write barrier needed since this is a new allocation. */ SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrBytes_bytes(p) = n; return (p); @@ -147,6 +148,7 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment ) <alignment> is a power of 2, which is technically not guaranteed */ p = p + ((-p - SIZEOF_StgArrBytes) & (alignment - 1)); + /* No write barrier needed since this is a new allocation. */ SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrBytes_bytes(p) = n; return (p); @@ -257,6 +259,7 @@ stg_newArrayzh ( W_ n /* words */, gcptr init ) } TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); + /* No write barrier needed since this is a new allocation. */ SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); StgMutArrPtrs_ptrs(arr) = n; StgMutArrPtrs_size(arr) = size; @@ -408,6 +411,7 @@ stg_newSmallArrayzh ( W_ n /* words */, gcptr init ) } TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0); + /* No write barrier needed since this is a new allocation. */ SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS); StgSmallMutArrPtrs_ptrs(arr) = n; @@ -522,6 +526,7 @@ stg_newMutVarzh ( gcptr init ) ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init); mv = Hp - SIZEOF_StgMutVar + WDS(1); + /* No write barrier needed since this is a new allocation. */ SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS); StgMutVar_var(mv) = init; @@ -700,6 +705,7 @@ stg_mkWeakzh ( gcptr key, ALLOC_PRIM (SIZEOF_StgWeak) w = Hp - SIZEOF_StgWeak + WDS(1); + // No memory barrier needed as this is a new allocation. SET_HDR(w, stg_WEAK_info, CCCS); StgWeak_key(w) = key; @@ -815,6 +821,7 @@ stg_deRefWeakzh ( gcptr w ) gcptr val; info = GET_INFO(w); + prim_read_barrier; if (info == stg_WHITEHOLE_info) { // w is locked by another thread. Now it's not immediately clear if w is @@ -1386,11 +1393,13 @@ stg_readTVarzh (P_ tvar) stg_readTVarIOzh ( P_ tvar /* :: TVar a */ ) { - W_ result; + W_ result, resultinfo; again: result = StgTVar_current_value(tvar); - if (%INFO_PTR(result) == stg_TREC_HEADER_info) { + resultinfo = %INFO_PTR(result); + prim_read_barrier; + if (resultinfo == stg_TREC_HEADER_info) { goto again; } return (result); @@ -1459,6 +1468,7 @@ stg_newMVarzh () ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh); mvar = Hp - SIZEOF_StgMVar + WDS(1); + // No memory barrier needed as this is a new allocation. SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS); // MVARs start dirty: generation 0 has no mutable list StgMVar_head(mvar) = stg_END_TSO_QUEUE_closure; @@ -1483,7 +1493,7 @@ stg_newMVarzh () stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) { - W_ val, info, tso, q; + W_ val, info, tso, q, qinfo; LOCK_CLOSURE(mvar, info); @@ -1505,9 +1515,12 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1); - SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; + SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + // Write barrier before we make the new MVAR_TSO_QUEUE + // visible to other cores. + prim_write_barrier; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_head(mvar) = q; @@ -1537,8 +1550,10 @@ loop: unlockClosure(mvar, info); return (val); } - if (StgHeader_info(q) == stg_IND_info || - StgHeader_info(q) == stg_MSG_NULL_info) { + qinfo = StgHeader_info(q); + prim_read_barrier; + if (qinfo == stg_IND_info || + qinfo == stg_MSG_NULL_info) { q = StgInd_indirectee(q); goto loop; } @@ -1576,7 +1591,7 @@ loop: stg_tryTakeMVarzh ( P_ mvar /* :: MVar a */ ) { - W_ val, info, tso, q; + W_ val, info, tso, q, qinfo; LOCK_CLOSURE(mvar, info); @@ -1603,8 +1618,11 @@ loop: return (1, val); } - if (StgHeader_info(q) == stg_IND_info || - StgHeader_info(q) == stg_MSG_NULL_info) { + qinfo = StgHeader_info(q); + prim_read_barrier; + + if (qinfo == stg_IND_info || + qinfo == stg_MSG_NULL_info) { q = StgInd_indirectee(q); goto loop; } @@ -1643,7 +1661,7 @@ loop: stg_putMVarzh ( P_ mvar, /* :: MVar a */ P_ val, /* :: a */ ) { - W_ info, tso, q; + W_ info, tso, q, qinfo; LOCK_CLOSURE(mvar, info); @@ -1663,10 +1681,12 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1); - SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; + SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + prim_write_barrier; + if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_head(mvar) = q; } else { @@ -1693,8 +1713,12 @@ loop: unlockClosure(mvar, stg_MVAR_DIRTY_info); return (); } - if (StgHeader_info(q) == stg_IND_info || - StgHeader_info(q) == stg_MSG_NULL_info) { + + qinfo = StgHeader_info(q); + prim_read_barrier; + + if (qinfo == stg_IND_info || + qinfo == stg_MSG_NULL_info) { q = StgInd_indirectee(q); goto loop; } @@ -1751,7 +1775,7 @@ loop: stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */ P_ val, /* :: a */ ) { - W_ info, tso, q; + W_ info, tso, q, qinfo; LOCK_CLOSURE(mvar, info); @@ -1774,8 +1798,12 @@ loop: unlockClosure(mvar, stg_MVAR_DIRTY_info); return (1); } - if (StgHeader_info(q) == stg_IND_info || - StgHeader_info(q) == stg_MSG_NULL_info) { + + qinfo = StgHeader_info(q); + prim_read_barrier; + + if (qinfo == stg_IND_info || + qinfo == stg_MSG_NULL_info) { q = StgInd_indirectee(q); goto loop; } @@ -1846,10 +1874,12 @@ stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) // readMVars are pushed to the front of the queue, so // they get handled immediately - SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); StgMVarTSOQueue_link(q) = StgMVar_head(mvar); StgMVarTSOQueue_tso(q) = CurrentTSO; + SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + prim_write_barrier; + StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; @@ -1914,6 +1944,10 @@ stg_makeStableNamezh ( P_ obj ) BYTES_TO_WDS(SIZEOF_StgStableName)); SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS); StgStableName_sn(sn_obj) = index; + // This will make the StableName# object visible to other threads; + // be sure that its completely visible to other cores. + // See Note [Heap memory barriers] in SMP.h. + prim_write_barrier; snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) = sn_obj; } else { sn_obj = snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry); @@ -1955,6 +1989,7 @@ stg_newBCOzh ( P_ instrs, ALLOC_PRIM (bytes); bco = Hp - bytes + WDS(1); + // No memory barrier necessary as this is a new allocation. SET_HDR(bco, stg_BCO_info, CCS_MAIN); StgBCO_instrs(bco) = instrs; @@ -1991,6 +2026,7 @@ stg_mkApUpd0zh ( P_ bco ) CCCS_ALLOC(SIZEOF_StgAP); ap = Hp - SIZEOF_StgAP + WDS(1); + // No memory barrier necessary as this is a new allocation. SET_HDR(ap, stg_AP_info, CCS_MAIN); StgAP_n_args(ap) = HALF_W_(0); @@ -2003,6 +2039,7 @@ stg_unpackClosurezh ( P_ closure ) { W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr; info = %GET_STD_INFO(UNTAG(closure)); + prim_read_barrier; ptrs = TO_W_(%INFO_PTRS(info)); nptrs = TO_W_(%INFO_NPTRS(info)); @@ -2324,7 +2361,10 @@ stg_noDuplicatezh /* no arg list: explicit stack layout */ stg_getApStackValzh ( P_ ap_stack, W_ offset ) { - if (%INFO_PTR(UNTAG(ap_stack)) == stg_AP_STACK_info) { + W_ ap_stackinfo; + ap_stackinfo = %INFO_PTR(UNTAG(ap_stack)); + prim_read_barrier; + if (ap_stackinfo == stg_AP_STACK_info) { return (1,StgAP_STACK_payload(ap_stack,offset)); } else { return (0,ap_stack); diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index f58f9177c8..807c3e3d30 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -870,6 +870,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, ap->payload[i] = (StgClosure *)*sp++; } + write_barrier(); // XXX: Necessary? SET_HDR(ap,&stg_AP_STACK_info, ((StgClosure *)frame)->header.prof.ccs /* ToDo */); TICK_ALLOC_UP_THK(WDS(words+1),0); diff --git a/rts/Sparks.c b/rts/Sparks.c index bd5e120863..4022691da2 100644 --- a/rts/Sparks.c +++ b/rts/Sparks.c @@ -182,6 +182,7 @@ pruneSparkQueue (Capability *cap) traceEventSparkFizzle(cap); } else { info = spark->header.info; + load_load_barrier(); if (IS_FORWARDING_PTR(info)) { tmp = (StgClosure*)UN_FORWARDING_PTR(info); /* if valuable work: shift inside the pool */ diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index fdd9f1565e..e80ce45172 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -292,12 +292,14 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: + prim_read_barrier; p = StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } info = StgHeader_info(p); + prim_read_barrier; if (info == stg_IND_info) { // This could happen, if e.g. we got a BLOCKING_QUEUE that has // just been replaced with an IND by another thread in @@ -313,9 +315,11 @@ retry: ("ptr" msg) = ccall allocate(MyCapability() "ptr", BYTES_TO_WDS(SIZEOF_MessageBlackHole)); - SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM); MessageBlackHole_tso(msg) = CurrentTSO; MessageBlackHole_bh(msg) = node; + SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM); + // messageBlackHole has appropriate memory barriers when this object is exposed. + // See Note [Heap memory barriers]. (r) = ccall messageBlackHole(MyCapability() "ptr", msg "ptr"); diff --git a/rts/ThreadPaused.c b/rts/ThreadPaused.c index a916891aa8..cccc7ad0b0 100644 --- a/rts/ThreadPaused.c +++ b/rts/ThreadPaused.c @@ -195,6 +195,7 @@ threadPaused(Capability *cap, StgTSO *tso) const StgRetInfoTable *info; const StgInfoTable *bh_info; const StgInfoTable *cur_bh_info USED_IF_THREADS; + const StgInfoTable *frame_info; StgClosure *bh; StgPtr stack_end; uint32_t words_to_squeeze = 0; @@ -218,6 +219,8 @@ threadPaused(Capability *cap, StgTSO *tso) frame = (StgClosure *)tso->stackobj->sp; + // N.B. We know that the TSO is owned by the current capability so no + // memory barriers are needed here. while ((P_)frame < stack_end) { info = get_ret_itbl(frame); @@ -226,7 +229,8 @@ threadPaused(Capability *cap, StgTSO *tso) case UPDATE_FRAME: // If we've already marked this frame, then stop here. - if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) { + frame_info = frame->header.info; + if (frame_info == (StgInfoTable *)&stg_marked_upd_frame_info) { if (prev_was_update_frame) { words_to_squeeze += sizeofW(StgUpdateFrame); weight += weight_pending; diff --git a/rts/Threads.c b/rts/Threads.c index 977635322d..2bdcea1c00 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -126,6 +126,8 @@ createThread(Capability *cap, W_ size) ACQUIRE_LOCK(&sched_mutex); tso->id = next_thread_id++; // while we have the mutex tso->global_link = g0->threads; + /* Mutations above need no memory barrier since this lock will provide + * a release barrier */ g0->threads = tso; RELEASE_LOCK(&sched_mutex); @@ -257,8 +259,10 @@ tryWakeupThread (Capability *cap, StgTSO *tso) { MessageWakeup *msg; msg = (MessageWakeup *)allocate(cap,sizeofW(MessageWakeup)); - SET_HDR(msg, &stg_MSG_TRY_WAKEUP_info, CCS_SYSTEM); msg->tso = tso; + SET_HDR(msg, &stg_MSG_TRY_WAKEUP_info, CCS_SYSTEM); + // Ensure that writes constructing Message are committed before sending. + write_barrier(); sendMessage(cap, tso->cap, (Message*)msg); debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld on cap %d", (W_)tso->id, tso->cap->no); @@ -363,6 +367,7 @@ wakeBlockingQueue(Capability *cap, StgBlockingQueue *bq) for (msg = bq->queue; msg != (MessageBlackHole*)END_TSO_QUEUE; msg = msg->link) { i = msg->header.info; + load_load_barrier(); if (i != &stg_IND_info) { ASSERT(i == &stg_MSG_BLACKHOLE_info); tryWakeupThread(cap,msg->tso); @@ -392,15 +397,18 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) for (bq = tso->bq; bq != (StgBlockingQueue*)END_TSO_QUEUE; bq = next) { next = bq->link; - if (bq->header.info == &stg_IND_info) { + const StgInfoTable *bqinfo = bq->header.info; + load_load_barrier(); // XXX: Is this needed? + if (bqinfo == &stg_IND_info) { // ToDo: could short it out right here, to avoid // traversing this IND multiple times. continue; } p = bq->bh; - - if (p->header.info != &stg_BLACKHOLE_info || + const StgInfoTable *pinfo = p->header.info; + load_load_barrier(); + if (pinfo != &stg_BLACKHOLE_info || ((StgInd *)p)->indirectee != (StgClosure*)bq) { wakeBlockingQueue(cap,bq); @@ -424,6 +432,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) const StgInfoTable *i; i = thunk->header.info; + load_load_barrier(); if (i != &stg_BLACKHOLE_info && i != &stg_CAF_BLACKHOLE_info && i != &__stg_EAGER_BLACKHOLE_info && @@ -444,6 +453,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) } i = v->header.info; + load_load_barrier(); if (i == &stg_TSO_info) { checkBlockingQueues(cap, tso); return; @@ -667,6 +677,8 @@ threadStackOverflow (Capability *cap, StgTSO *tso) new_stack->sp -= chunk_words; } + // No write barriers needed; all of the writes above are to structured + // owned by our capability. tso->stackobj = new_stack; // we're about to run it, better mark it dirty @@ -738,6 +750,7 @@ threadStackUnderflow (Capability *cap, StgTSO *tso) bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value) { const StgInfoTable *info; + const StgInfoTable *qinfo; StgMVarTSOQueue *q; StgTSO *tso; @@ -762,8 +775,11 @@ loop: unlockClosure((StgClosure*)mvar, &stg_MVAR_DIRTY_info); return true; } - if (q->header.info == &stg_IND_info || - q->header.info == &stg_MSG_NULL_info) { + + qinfo = q->header.info; + load_load_barrier(); + if (qinfo == &stg_IND_info || + qinfo == &stg_MSG_NULL_info) { q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; goto loop; } diff --git a/rts/TopHandler.c b/rts/TopHandler.c index c0ac936b85..d5175015e7 100644 --- a/rts/TopHandler.c +++ b/rts/TopHandler.c @@ -29,6 +29,7 @@ StgTSO *getTopHandlerThread(void) { StgWeak *weak = (StgWeak*)deRefStablePtr(topHandlerPtr); RELEASE_LOCK(&m); const StgInfoTable *info = weak->header.info; + load_load_barrier(); if (info == &stg_WEAK_info) { StgClosure *key = ((StgWeak*)weak)->key; diff --git a/rts/Updates.h b/rts/Updates.h index 1ba398bd35..1bd3e065af 100644 --- a/rts/Updates.h +++ b/rts/Updates.h @@ -39,10 +39,16 @@ PROF_HDR_FIELDS(w_,ccs,p2) \ p_ updatee - +/* + * Getting the memory barriers correct here is quite tricky. Essentially + * the write barrier ensures that any writes to the new indirectee are visible + * before we introduce the indirection. + * See Note [Heap memory barriers] in SMP.h. + */ #define updateWithIndirection(p1, p2, and_then) \ W_ bd; \ \ + prim_write_barrier; \ OVERWRITING_CLOSURE(p1); \ StgInd_indirectee(p1) = p2; \ prim_write_barrier; \ @@ -69,6 +75,8 @@ INLINE_HEADER void updateWithIndirection (Capability *cap, ASSERT( (P_)p1 != (P_)p2 ); /* not necessarily true: ASSERT( !closure_IND(p1) ); */ /* occurs in RaiseAsync.c:raiseAsync() */ + /* See Note [Heap memory barriers] in SMP.h */ + write_barrier(); OVERWRITING_CLOSURE(p1); ((StgInd *)p1)->indirectee = p2; write_barrier(); diff --git a/rts/Weak.c b/rts/Weak.c index a322d822af..ec998c214f 100644 --- a/rts/Weak.c +++ b/rts/Weak.c @@ -57,7 +57,9 @@ runAllCFinalizers(StgWeak *list) // If there's no major GC between the time that the finalizer for the // object from the oldest generation is manually called and shutdown // we end up running the same finalizer twice. See #7170. - if (w->header.info != &stg_DEAD_WEAK_info) { + const StgInfoTable *winfo = w->header.info; + load_load_barrier(); + if (winfo != &stg_DEAD_WEAK_info) { runCFinalizers((StgCFinalizerList *)w->cfinalizers); } } @@ -138,6 +140,7 @@ scheduleFinalizers(Capability *cap, StgWeak *list) size = n + mutArrPtrsCardTableSize(n); arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size); TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0); + // No write barrier needed here; this array is only going to referred to by this core. SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, CCS_SYSTEM); arr->ptrs = n; arr->size = size; diff --git a/rts/linker/M32Alloc.c b/rts/linker/M32Alloc.c index 52b182e54d..33c4335286 100644 --- a/rts/linker/M32Alloc.c +++ b/rts/linker/M32Alloc.c @@ -24,7 +24,7 @@ Note [Compile Time Trickery] This file implements two versions of each of the `m32_*` functions. At the top of the file there is the real implementation (compiled in when `RTS_LINKER_USE_MMAP` is true) and a dummy implementation that exists only to -satisfy the compiler and which hould never be called. If any of these dummy +satisfy the compiler and which should never be called. If any of these dummy implementations are called the program will abort. The rationale for this is to allow the calling code to be written without using diff --git a/rts/sm/CNF.c b/rts/sm/CNF.c index 8d0ebccaf3..eee8e9770b 100644 --- a/rts/sm/CNF.c +++ b/rts/sm/CNF.c @@ -542,8 +542,9 @@ insertCompactHash (Capability *cap, StgClosure *p, StgClosure *to) { insertHashTable(str->hash, (StgWord)p, (const void*)to); - if (str->header.info == &stg_COMPACT_NFDATA_CLEAN_info) { - str->header.info = &stg_COMPACT_NFDATA_DIRTY_info; + const StgInfoTable *strinfo = str->header.info; + if (strinfo == &stg_COMPACT_NFDATA_CLEAN_info) { + strinfo = &stg_COMPACT_NFDATA_DIRTY_info; recordClosureMutated(cap, (StgClosure*)str); } } diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 289031945d..f080221e28 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -131,7 +131,7 @@ copy_tag(StgClosure **p, const StgInfoTable *info, #else src->header.info = (const StgInfoTable *)MK_FORWARDING_PTR(to); *p = TAG_CLOSURE(tag,(StgClosure*)to); -#endif +#endif /* defined(PARALLEL_GC) */ #if defined(PROFILING) // We store the size of the just evacuated object in the LDV word so that @@ -194,7 +194,7 @@ spin: if (info == (W_)&stg_WHITEHOLE_info) { #if defined(PROF_SPIN) whitehole_gc_spin++; -#endif +#endif /* PROF_SPIN */ busy_wait_nop(); goto spin; } @@ -205,7 +205,7 @@ spin: } #else info = (W_)src->header.info; -#endif +#endif /* PARALLEL_GC */ to = alloc_for_copy(size_to_reserve, gen_no); @@ -216,8 +216,8 @@ spin: } write_barrier(); - src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to); *p = (StgClosure *)to; + src->header.info = (const StgInfoTable*)MK_FORWARDING_PTR(to); #if defined(PROFILING) // We store the size of the just evacuated object in the LDV word so that @@ -1099,6 +1099,7 @@ selector_chain: // need the write-barrier stuff. // - undo the chain we've built to point to p. SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + write_barrier(); *q = (StgClosure *)p; if (evac) evacuate(q); unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); @@ -1109,7 +1110,7 @@ selector_chain: // Save the real info pointer (NOTE: not the same as get_itbl()). info_ptr = (StgWord)p->header.info; SET_INFO((StgClosure *)p,&stg_WHITEHOLE_info); -#endif +#endif /* THREADED_RTS */ field = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->layout.selector_offset; @@ -1165,6 +1166,7 @@ selector_loop: SET_INFO((StgClosure*)p, (StgInfoTable *)info_ptr); OVERWRITING_CLOSURE((StgClosure*)p); SET_INFO((StgClosure*)p, &stg_WHITEHOLE_info); + write_barrier(); } #endif diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 70d6d8efe5..8a8e1573dd 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -1097,6 +1097,8 @@ loop: // scavenge_loop() only exits when there's no work to do + // This atomic decrement also serves as a full barrier to ensure that any + // writes we made during scavenging are visible to other threads. #if defined(DEBUG) r = dec_running(); #else diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c index 23ed3f0622..650dc2c1df 100644 --- a/rts/sm/GCAux.c +++ b/rts/sm/GCAux.c @@ -83,6 +83,7 @@ isAlive(StgClosure *p) } info = INFO_PTR_TO_STRUCT(info); + load_load_barrier(); switch (info->type) { @@ -114,16 +115,21 @@ isAlive(StgClosure *p) void revertCAFs( void ) { - StgIndStatic *c; + StgIndStatic *c = revertible_caf_list; - for (c = revertible_caf_list; - c != (StgIndStatic *)END_OF_CAF_LIST; - c = (StgIndStatic *)c->static_link) - { + while (c != (StgIndStatic *) END_OF_CAF_LIST) { c = (StgIndStatic *)UNTAG_STATIC_LIST_PTR(c); + StgIndStatic *next = (StgIndStatic *) c->static_link; + SET_INFO((StgClosure *)c, c->saved_info); c->saved_info = NULL; - // could, but not necessary: c->static_link = NULL; + // We must reset static_link lest the major GC finds that + // static_flag==3 and will consequently ignore references + // into code that we are trying to unload. This would result + // in reachable object code being unloaded prematurely. + // See #16842. + c->static_link = NULL; + c = next; } revertible_caf_list = (StgIndStatic*)END_OF_CAF_LIST; } diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c index d7b8fe696f..8fe9788fd2 100644 --- a/rts/sm/MarkWeak.c +++ b/rts/sm/MarkWeak.c @@ -242,16 +242,22 @@ static bool tidyWeakList(generation *gen) last_w = &gen->old_weak_ptr_list; for (w = gen->old_weak_ptr_list; w != NULL; w = next_w) { + info = w->header.info; + /* N.B. This function is executed only during the serial part of GC + * so consequently there is no potential for data races and therefore + * no need for memory barriers. + */ + /* There might be a DEAD_WEAK on the list if finalizeWeak# was * called on a live weak pointer object. Just remove it. */ - if (w->header.info == &stg_DEAD_WEAK_info) { + if (info == &stg_DEAD_WEAK_info) { next_w = w->link; *last_w = next_w; continue; } - info = get_itbl((StgClosure *)w); + info = INFO_PTR_TO_STRUCT(info); switch (info->type) { case WEAK: diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 8082b7e6d0..ff76f747c9 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -233,6 +233,7 @@ checkClosure( const StgClosure* p ) p = UNTAG_CONST_CLOSURE(p); info = p->header.info; + load_load_barrier(); if (IS_FORWARDING_PTR(info)) { barf("checkClosure: found EVACUATED closure %d", info->type); @@ -243,6 +244,7 @@ checkClosure( const StgClosure* p ) #endif info = INFO_PTR_TO_STRUCT(info); + load_load_barrier(); switch (info->type) { @@ -564,6 +566,7 @@ checkTSO(StgTSO *tso) next = tso->_link; info = (const StgInfoTable*) tso->_link->header.info; + load_load_barrier(); ASSERT(next == END_TSO_QUEUE || info == &stg_MVAR_TSO_QUEUE_info || diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 8bc702900b..00f21c3039 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -425,7 +425,7 @@ scavenge_block (bdescr *bd) // time around the loop. while (p < bd->free || (bd == ws->todo_bd && p < ws->todo_free)) { - ASSERT(bd->link == NULL); + ASSERT(bd->link == NULL); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); info = get_itbl((StgClosure *)p); @@ -1574,6 +1574,7 @@ scavenge_mutable_list(bdescr *bd, generation *gen) ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); #if defined(DEBUG) + const StgInfoTable *pinfo; switch (get_itbl((StgClosure *)p)->type) { case MUT_VAR_CLEAN: // can happen due to concurrent writeMutVars @@ -1593,9 +1594,10 @@ scavenge_mutable_list(bdescr *bd, generation *gen) case TREC_CHUNK: mutlist_TREC_CHUNK++; break; case MUT_PRIM: - if (((StgClosure*)p)->header.info == &stg_TVAR_WATCH_QUEUE_info) + pinfo = ((StgClosure*)p)->header.info; + if (pinfo == &stg_TVAR_WATCH_QUEUE_info) mutlist_TVAR_WATCH_QUEUE++; - else if (((StgClosure*)p)->header.info == &stg_TREC_HEADER_info) + else if (pinfo == &stg_TREC_HEADER_info) mutlist_TREC_HEADER++; else mutlist_OTHERS++; diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index dcc5b3a3c7..f4356d0b61 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -407,8 +407,10 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) // Allocate the blackhole indirection closure bh = (StgInd *)allocate(cap, sizeofW(*bh)); - SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; + SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); + // Ensure that above writes are visible before we introduce reference as CAF indirectee. + write_barrier(); caf->indirectee = (StgClosure *)bh; write_barrier(); @@ -1081,6 +1083,8 @@ void dirty_MUT_VAR(StgRegTable *reg, StgClosure *p) { Capability *cap = regTableToCapability(reg); + // No barrier required here as no other heap object fields are read. See + // note [Heap memory barriers] in SMP.h. if (p->header.info == &stg_MUT_VAR_CLEAN_info) { p->header.info = &stg_MUT_VAR_DIRTY_info; recordClosureMutated(cap,p); @@ -1090,6 +1094,8 @@ dirty_MUT_VAR(StgRegTable *reg, StgClosure *p) void dirty_TVAR(Capability *cap, StgTVar *p) { + // No barrier required here as no other heap object fields are read. See + // note [Heap memory barriers] in SMP.h. if (p->header.info == &stg_TVAR_CLEAN_info) { p->header.info = &stg_TVAR_DIRTY_info; recordClosureMutated(cap,(StgClosure*)p); @@ -1363,13 +1369,18 @@ StgWord calcTotalCompactW (void) #include <libkern/OSCacheControl.h> #endif +/* __builtin___clear_cache is supported since GNU C 4.3.6. + * We pick 4.4 to simplify condition a bit. + */ +#define GCC_HAS_BUILTIN_CLEAR_CACHE (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) + #if defined(__clang__) /* clang defines __clear_cache as a builtin on some platforms. * For example on armv7-linux-androideabi. The type slightly * differs from gcc. */ extern void __clear_cache(void * begin, void * end); -#elif defined(__GNUC__) +#elif defined(__GNUC__) && !GCC_HAS_BUILTIN_CLEAR_CACHE /* __clear_cache is a libgcc function. * It existed before __builtin___clear_cache was introduced. * See Trac #8562. @@ -1397,15 +1408,12 @@ void flushExec (W_ len, AdjustorExecutable exec_addr) __clear_cache((void*)begin, (void*)end); # endif #elif defined(__GNUC__) - /* For all other platforms, fall back to a libgcc builtin. */ unsigned char* begin = (unsigned char*)exec_addr; unsigned char* end = begin + len; - /* __builtin___clear_cache is supported since GNU C 4.3.6. - * We pick 4.4 to simplify condition a bit. - */ -# if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) +# if GCC_HAS_BUILTIN_CLEAR_CACHE __builtin___clear_cache((void*)begin, (void*)end); # else + /* For all other platforms, fall back to a libgcc builtin. */ __clear_cache((void*)begin, (void*)end); # endif #else diff --git a/testsuite/tests/backpack/should_run/bkprun05.bkp b/testsuite/tests/backpack/should_run/bkprun05.bkp index de2374f569..6db2daa963 100644 --- a/testsuite/tests/backpack/should_run/bkprun05.bkp +++ b/testsuite/tests/backpack/should_run/bkprun05.bkp @@ -133,7 +133,7 @@ unit app where app = do let x = insert 0 "foo" . delete 1 - . insert 1 undefined + . insert 1 (errorWithoutStackTrace "this is an error") . insert (6 :: Int) "foo" $ empty print (member 1 x) diff --git a/testsuite/tests/backpack/should_run/bkprun05.stderr b/testsuite/tests/backpack/should_run/bkprun05.stderr index 12d7d92d2d..7f5f1a544f 100644 --- a/testsuite/tests/backpack/should_run/bkprun05.stderr +++ b/testsuite/tests/backpack/should_run/bkprun05.stderr @@ -1,4 +1,2 @@ -bkprun05: Prelude.undefined -CallStack (from HasCallStack): - error, called at libraries/base/GHC/Err.hs:78:14 in base:GHC.Err - undefined, called at bkprun05.bkp:136:30 in app+app-18HBpsO5TPxCVSTvBQxSrq:App +bkprun05: this is an error + diff --git a/testsuite/tests/cabal/cabal10/Makefile b/testsuite/tests/cabal/cabal10/Makefile new file mode 100644 index 0000000000..b59c964db4 --- /dev/null +++ b/testsuite/tests/cabal/cabal10/Makefile @@ -0,0 +1,21 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP = ./Setup -v0 + +# This test is for packages in internal libraries + +cabal10: clean + $(MAKE) clean + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + $(SETUP) clean + $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' + $(SETUP) build + '$(TEST_HC)' $(TEST_HC_OPTS) -package-db dist/package.conf.inplace Use.hs +ifneq "$(CLEANUP)" "" + $(MAKE) clean +endif + +clean : + $(RM) -r */dist Setup$(exeext) *.o *.hi diff --git a/testsuite/tests/cabal/cabal10/Setup.hs b/testsuite/tests/cabal/cabal10/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal10/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal10/Use.hs b/testsuite/tests/cabal/cabal10/Use.hs new file mode 100644 index 0000000000..b770515501 --- /dev/null +++ b/testsuite/tests/cabal/cabal10/Use.hs @@ -0,0 +1,3 @@ +module Use where + +import TestLib diff --git a/testsuite/tests/cabal/cabal10/all.T b/testsuite/tests/cabal/cabal10/all.T new file mode 100644 index 0000000000..778637d948 --- /dev/null +++ b/testsuite/tests/cabal/cabal10/all.T @@ -0,0 +1,9 @@ +if config.cleanup: + cleanup = 'CLEANUP=1' +else: + cleanup = 'CLEANUP=0' + +test('cabal10', + extra_files(['Use.hs', 'Setup.hs', 'src/', 'internal-lib.cabal']), + run_command, + ['$MAKE -s --no-print-directory cabal10 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal10/cabal10.stdout b/testsuite/tests/cabal/cabal10/cabal10.stdout new file mode 100644 index 0000000000..b7ea26c0d1 --- /dev/null +++ b/testsuite/tests/cabal/cabal10/cabal10.stdout @@ -0,0 +1 @@ +[1 of 1] Compiling Use ( Use.hs, Use.o ) diff --git a/testsuite/tests/cabal/cabal10/internal-lib.cabal b/testsuite/tests/cabal/cabal10/internal-lib.cabal new file mode 100644 index 0000000000..27e8ded0bf --- /dev/null +++ b/testsuite/tests/cabal/cabal10/internal-lib.cabal @@ -0,0 +1,13 @@ +name: internal-lib +version: 0.1.0.0 +license: BSD3 +build-type: Simple +cabal-version: >=2.0 + +library + hs-source-dirs: src + exposed-modules: TestLib + build-depends: base + default-language: Haskell2010 + +library sublib diff --git a/testsuite/tests/cabal/cabal10/src/TestLib.hs b/testsuite/tests/cabal/cabal10/src/TestLib.hs new file mode 100644 index 0000000000..c031432cb1 --- /dev/null +++ b/testsuite/tests/cabal/cabal10/src/TestLib.hs @@ -0,0 +1 @@ +module TestLib where diff --git a/testsuite/tests/codeGen/should_fail/T13233.hs b/testsuite/tests/codeGen/should_fail/T13233.hs index 1facb77914..251f4aee33 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.hs +++ b/testsuite/tests/codeGen/should_fail/T13233.hs @@ -21,6 +21,9 @@ obscure _ = () quux :: () quux = obscure (#,#) +-- It used to be that primops has no binding. However, as described in +-- Note [Primop wrappers] in PrimOp we now rewrite unsaturated primop +-- applications to their wrapper, which allows safe use of levity polymorphism. primop :: forall (rep :: RuntimeRep) (a :: TYPE rep) b c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #) diff --git a/testsuite/tests/codeGen/should_fail/T13233.stderr b/testsuite/tests/codeGen/should_fail/T13233.stderr index c3683138f8..6847d43868 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.stderr +++ b/testsuite/tests/codeGen/should_fail/T13233.stderr @@ -15,12 +15,3 @@ T13233.hs:22:16: error: Levity-polymorphic arguments: a :: TYPE rep1 b :: TYPE rep2 - -T13233.hs:27:10: error: - Cannot use primitive with levity-polymorphic arguments: - mkWeak# :: a - -> b - -> (State# RealWorld -> (# State# RealWorld, c #)) - -> State# RealWorld - -> (# State# RealWorld, Weak# b #) - Levity-polymorphic arguments: a :: TYPE rep diff --git a/testsuite/tests/codeGen/should_run/T16846.hs b/testsuite/tests/codeGen/should_run/T16846.hs new file mode 100644 index 0000000000..af961fe681 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T16846.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +module Main (main) where + +import Control.Concurrent.STM + +data Free f a = Pure a | Free (f (Free f a)) + +data SuspendF a + = forall r. StepSTM (STM r) + | forall r. StepIO (IO r) + +effect :: STM a -> Free SuspendF a +effect a = Free $ StepSTM a + +io :: IO a -> Free SuspendF a +io a = Free $ StepIO a + +comb :: [Free SuspendF a] -> Free SuspendF a +comb vs = io $ do + _ <- mapM go vs + undefined + +go :: Free SuspendF a -> IO (STM ()) +go (Free (StepIO a)) = a >>= \_ -> go $ Pure undefined +go (Free (StepSTM a)) = pure $ a >>= \_ -> pure () +go (Pure _) = pure $ pure () + +runWidget :: Free SuspendF a -> IO a +runWidget w = case w of + Free (StepIO io) -> do + _ <- io + undefined + +-- Uncommenting this hid the original bug. +--main :: IO () +main = runWidget $ comb $ replicate 10000000 (effect retry) diff --git a/testsuite/tests/codeGen/should_run/T16846.stderr b/testsuite/tests/codeGen/should_run/T16846.stderr new file mode 100644 index 0000000000..f737c83af0 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T16846.stderr @@ -0,0 +1,4 @@ +T16846: Prelude.undefined +CallStack (from HasCallStack): + error, called at libraries/base/GHC/Err.hs:80:14 in base:GHC.Err + undefined, called at T16846.hs:22:3 in main:Main diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index 06dd0a0e52..1aa829d9e4 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -193,3 +193,4 @@ test('T15892', extra_run_opts('+RTS -G1 -A32k -RTS') ], compile_and_run, ['-O']) test('T16449_2', exit_code(0), compile_and_run, ['']) +test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, ['']) diff --git a/testsuite/tests/dependent/should_fail/DepFail1.stderr b/testsuite/tests/dependent/should_fail/DepFail1.stderr index a8e64d4e0c..0201005943 100644 --- a/testsuite/tests/dependent/should_fail/DepFail1.stderr +++ b/testsuite/tests/dependent/should_fail/DepFail1.stderr @@ -4,23 +4,7 @@ DepFail1.hs:7:6: error: Expected a type, but ‘Proxy Bool’ has kind ‘Bool -> *’ • In the type signature: z :: Proxy Bool -DepFail1.hs:8:5: error: - • Couldn't match expected type ‘Proxy Bool’ - with actual type ‘Proxy k0 a1’ - • In the expression: P - In an equation for ‘z’: z = P - DepFail1.hs:10:16: error: • Expected kind ‘Int’, but ‘Bool’ has kind ‘*’ • In the second argument of ‘Proxy’, namely ‘Bool’ In the type signature: a :: Proxy Int Bool - -DepFail1.hs:11:5: error: - • Couldn't match kind ‘*’ with ‘Int’ - When matching types - a0 :: Int - Bool :: * - Expected type: Proxy Int Bool - Actual type: Proxy Int a0 - • In the expression: P - In an equation for ‘a’: a = P diff --git a/testsuite/tests/driver/T10970.stdout b/testsuite/tests/driver/T10970.stdout index bf26c89bd8..697781145f 100644 --- a/testsuite/tests/driver/T10970.stdout +++ b/testsuite/tests/driver/T10970.stdout @@ -1,2 +1,2 @@ -0.6.0.1 +0.6.2.1 OK diff --git a/testsuite/tests/driver/T16608/Makefile b/testsuite/tests/driver/T16608/Makefile new file mode 100644 index 0000000000..7cec19026b --- /dev/null +++ b/testsuite/tests/driver/T16608/Makefile @@ -0,0 +1,19 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T16608_1: + '$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_1.hs + ./T16608_1 + sleep 1 + sed -i -e 's/{- . succ -}/. succ/' MyInteger.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_1.hs + ./T16608_1 + +T16608_2: + '$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_2.hs + ./T16608_2 + sleep 1 + sed -i -e 's/{- . succ -}/. succ/' MyInteger.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_2.hs + ./T16608_2 diff --git a/testsuite/tests/driver/T16608/MyInteger.hs b/testsuite/tests/driver/T16608/MyInteger.hs new file mode 100644 index 0000000000..a7c731ed8c --- /dev/null +++ b/testsuite/tests/driver/T16608/MyInteger.hs @@ -0,0 +1,12 @@ +module MyInteger + ( MyInteger (MyInteger) + , ToMyInteger (toMyInteger) + ) where + +newtype MyInteger = MyInteger Integer + +class ToMyInteger a where + toMyInteger :: a -> MyInteger + +instance ToMyInteger Integer where + toMyInteger = MyInteger {- . succ -} diff --git a/testsuite/tests/driver/T16608/T16608_1.hs b/testsuite/tests/driver/T16608/T16608_1.hs new file mode 100644 index 0000000000..87a5000dab --- /dev/null +++ b/testsuite/tests/driver/T16608/T16608_1.hs @@ -0,0 +1,11 @@ +module Main + ( main + ) where + +import MyInteger (MyInteger (MyInteger), toMyInteger) + +main :: IO () +main = do + let (MyInteger i) = toMyInteger (41 :: Integer) + print i + diff --git a/testsuite/tests/driver/T16608/T16608_1.stdout b/testsuite/tests/driver/T16608/T16608_1.stdout new file mode 100644 index 0000000000..05c44cb5a8 --- /dev/null +++ b/testsuite/tests/driver/T16608/T16608_1.stdout @@ -0,0 +1,7 @@ +[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +[2 of 2] Compiling Main ( T16608_1.hs, T16608_1.o ) +Linking T16608_1 ... +41 +[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +Linking T16608_1 ... +42 diff --git a/testsuite/tests/driver/T16608/T16608_2.hs b/testsuite/tests/driver/T16608/T16608_2.hs new file mode 100644 index 0000000000..34eaddabf0 --- /dev/null +++ b/testsuite/tests/driver/T16608/T16608_2.hs @@ -0,0 +1,10 @@ +module Main + ( main + ) where + +import MyInteger (MyInteger (MyInteger), toMyInteger) + +main :: IO () +main = do + let (MyInteger i) = (id . toMyInteger) (41 :: Integer) + print i diff --git a/testsuite/tests/driver/T16608/T16608_2.stdout b/testsuite/tests/driver/T16608/T16608_2.stdout new file mode 100644 index 0000000000..9ca19a6dba --- /dev/null +++ b/testsuite/tests/driver/T16608/T16608_2.stdout @@ -0,0 +1,7 @@ +[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +[2 of 2] Compiling Main ( T16608_2.hs, T16608_2.o ) +Linking T16608_2 ... +41 +[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +Linking T16608_2 ... +42 diff --git a/testsuite/tests/driver/T16608/all.T b/testsuite/tests/driver/T16608/all.T new file mode 100644 index 0000000000..2f3864ec36 --- /dev/null +++ b/testsuite/tests/driver/T16608/all.T @@ -0,0 +1,4 @@ +test('T16608_1', [extra_files(['MyInteger.hs'])], run_command, + ['$MAKE -s --no-print-directory T16608_1']) +test('T16608_2', [extra_files(['MyInteger.hs'])], run_command, + ['$MAKE -s --no-print-directory T16608_2']) diff --git a/testsuite/tests/driver/T16737.hs b/testsuite/tests/driver/T16737.hs new file mode 100644 index 0000000000..0abe5457b0 --- /dev/null +++ b/testsuite/tests/driver/T16737.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -DFOO=2 -optP=-DBAR=3 -optc=-DBAZ=5 #-} + +import Language.Haskell.TH.Syntax + +do + let code = unlines + [ "#if defined(__cplusplus)" + , "extern \"C\" {" + , "#endif" + , "#include <T16737.h>" + , "int FUN(void) {" + , " return FOO * BAR * BAZ;" + , "}" + , "#if defined(__cplusplus)" + , "}" + , "#endif" + ] + addForeignSource LangC code + addForeignSource LangCxx code + pure [] + +foreign import ccall unsafe "c_value" + c_value :: IO Int + +foreign import ccall unsafe "cxx_value" + cxx_value :: IO Int + +main :: IO () +main = do + print =<< c_value + print =<< cxx_value diff --git a/testsuite/tests/driver/T16737.stdout b/testsuite/tests/driver/T16737.stdout new file mode 100644 index 0000000000..285b16f691 --- /dev/null +++ b/testsuite/tests/driver/T16737.stdout @@ -0,0 +1,2 @@ +30 +30 diff --git a/testsuite/tests/driver/T16737include/T16737.h b/testsuite/tests/driver/T16737include/T16737.h new file mode 100644 index 0000000000..08c7ca8729 --- /dev/null +++ b/testsuite/tests/driver/T16737include/T16737.h @@ -0,0 +1,7 @@ +#pragma once + +#if defined(__cplusplus) +#define FUN cxx_value +#else +#define FUN c_value +#endif diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 02eeeb321b..668d609747 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -287,3 +287,7 @@ test('inline-check', omit_ways(['hpc', 'profasm']) test('T14452', [], run_command, ['$MAKE -s --no-print-directory T14452']) test('T15396', normal, compile_and_run, ['-package ghc']) +test('T16737', + [when(ghc_dynamic(), omit_ways(['profasm'])), extra_files(['T16737include/'])], + compile_and_run, + ['-optP=-isystem -optP=T16737include']) diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stdout b/testsuite/tests/ghci.debugger/scripts/break006.stdout index 2b4a6c20f8..407ad3739b 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break006.stdout @@ -4,14 +4,14 @@ f :: Int -> a = _ x :: Int = 1 xs :: [Int] = [2,3] xs :: [Int] = [2,3] -f :: Int -> a = _ x :: Int = 1 +f :: Int -> a = _ _result :: [a] = _ y = (_t1::a) y = 2 xs :: [Int] = [2,3] -f :: Int -> Int = _ x :: Int = 1 +f :: Int -> Int = _ _result :: [Int] = _ y :: Int = 2 _t1 :: Int = 2 diff --git a/testsuite/tests/ghci.debugger/scripts/break013.stdout b/testsuite/tests/ghci.debugger/scripts/break013.stdout index 52aa48ee83..0024bc62d0 100644 --- a/testsuite/tests/ghci.debugger/scripts/break013.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break013.stdout @@ -3,7 +3,7 @@ _result :: (Bool, Bool, ()) = _ a :: Bool = _ b :: Bool = _ c :: () = _ -b :: Bool = _ c :: () = _ +b :: Bool = _ a :: Bool = _ _result :: (Bool, Bool, ()) = _ diff --git a/testsuite/tests/ghci.debugger/scripts/hist001.stdout b/testsuite/tests/ghci.debugger/scripts/hist001.stdout index b52e8aa5fe..a19a34f315 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist001.stdout @@ -20,8 +20,8 @@ _result :: a f :: Integer -> a x :: Integer xs :: [t] = [] -f :: Integer -> a = _ x :: Integer = 2 +f :: Integer -> a = _ _result :: a = _ _result = 3 Logged breakpoint at Test3.hs:2:18-31 diff --git a/testsuite/tests/ghci.debugger/scripts/hist002.stdout b/testsuite/tests/ghci.debugger/scripts/hist002.stdout index b52e8aa5fe..a19a34f315 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist002.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist002.stdout @@ -20,8 +20,8 @@ _result :: a f :: Integer -> a x :: Integer xs :: [t] = [] -f :: Integer -> a = _ x :: Integer = 2 +f :: Integer -> a = _ _result :: a = _ _result = 3 Logged breakpoint at Test3.hs:2:18-31 diff --git a/testsuite/tests/ghci/T13786/Makefile b/testsuite/tests/ghci/T13786/Makefile new file mode 100644 index 0000000000..560fc6bb36 --- /dev/null +++ b/testsuite/tests/ghci/T13786/Makefile @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T13786 +T13786 : + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c -fPIC T13786a.c + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c -fPIC T13786b.c + cat T13786.script | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -v0 T13786a.o T13786b.o T13786.hs diff --git a/testsuite/tests/ghci/T13786/T13786.hs b/testsuite/tests/ghci/T13786/T13786.hs new file mode 100644 index 0000000000..c9b9a7363f --- /dev/null +++ b/testsuite/tests/ghci/T13786/T13786.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +foreign import ccall unsafe "hello_a" helloA :: IO () + diff --git a/testsuite/tests/ghci/T13786/T13786.script b/testsuite/tests/ghci/T13786/T13786.script new file mode 100644 index 0000000000..e649e6553c --- /dev/null +++ b/testsuite/tests/ghci/T13786/T13786.script @@ -0,0 +1 @@ +helloA diff --git a/testsuite/tests/ghci/T13786/T13786.stdout b/testsuite/tests/ghci/T13786/T13786.stdout new file mode 100644 index 0000000000..a53815ed9c --- /dev/null +++ b/testsuite/tests/ghci/T13786/T13786.stdout @@ -0,0 +1,4 @@ +hello world A +hello world B +hello world A + diff --git a/testsuite/tests/ghci/T13786/T13786a.c b/testsuite/tests/ghci/T13786/T13786a.c new file mode 100644 index 0000000000..70a2774264 --- /dev/null +++ b/testsuite/tests/ghci/T13786/T13786a.c @@ -0,0 +1,15 @@ +#include <stdio.h> +#include <stdbool.h> + +static bool flag_a = false; + +extern void hello_b(); + +void hello_a() { + if (! flag_a) { + flag_a = true; + hello_b(); + } + + printf("hello world A\n"); +} diff --git a/testsuite/tests/ghci/T13786/T13786b.c b/testsuite/tests/ghci/T13786/T13786b.c new file mode 100644 index 0000000000..77314ea171 --- /dev/null +++ b/testsuite/tests/ghci/T13786/T13786b.c @@ -0,0 +1,16 @@ +#include <stdio.h> +#include <stdbool.h> + +static bool flag_b = false; + +extern void hello_a(); + +void hello_b() { + if (! flag_b) { + flag_b = true; + hello_a(); + } + + printf("hello world B\n"); +} + diff --git a/testsuite/tests/ghci/T13786/all.T b/testsuite/tests/ghci/T13786/all.T new file mode 100644 index 0000000000..fe02c37543 --- /dev/null +++ b/testsuite/tests/ghci/T13786/all.T @@ -0,0 +1,2 @@ +test('T13786', normal, run_command, ['$MAKE -s --no-print-directory T13786']) + diff --git a/testsuite/tests/ghci/T16525a/A.hs b/testsuite/tests/ghci/T16525a/A.hs new file mode 100644 index 0000000000..dc4ced10cb --- /dev/null +++ b/testsuite/tests/ghci/T16525a/A.hs @@ -0,0 +1,12 @@ +module A where + +import B + +myIntVal :: Int +myIntVal = sum [1,2,3,4] + +value :: [Value] +value = [Value "a;lskdfa;lszkfsd;alkfjas" myIntVal] + +v1 :: Value -> String +v1 (Value a _) = a diff --git a/testsuite/tests/ghci/T16525a/B.hs b/testsuite/tests/ghci/T16525a/B.hs new file mode 100644 index 0000000000..7be77cb1b6 --- /dev/null +++ b/testsuite/tests/ghci/T16525a/B.hs @@ -0,0 +1,3 @@ +module B where + +data Value = Value String Int diff --git a/testsuite/tests/ghci/T16525a/T16525a.script b/testsuite/tests/ghci/T16525a/T16525a.script new file mode 100644 index 0000000000..d48cfd0f2d --- /dev/null +++ b/testsuite/tests/ghci/T16525a/T16525a.script @@ -0,0 +1,6 @@ +:set -fobject-code +:load A +import Control.Concurrent +_ <- forkIO $ threadDelay 1000000 >> (print (map v1 value)) +:l [] +System.Mem.performGC diff --git a/testsuite/tests/ghci/T16525a/T16525a.stdout b/testsuite/tests/ghci/T16525a/T16525a.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghci/T16525a/T16525a.stdout diff --git a/testsuite/tests/ghci/T16525a/all.T b/testsuite/tests/ghci/T16525a/all.T new file mode 100644 index 0000000000..6fbd3e8a4f --- /dev/null +++ b/testsuite/tests/ghci/T16525a/all.T @@ -0,0 +1,5 @@ +test('T16525a', + [extra_files(['A.hs', 'B.hs', ]), + extra_run_opts('+RTS -DS -RTS'), + when(ghc_dynamic(), skip), ], + ghci_script, ['T16525a.script']) diff --git a/testsuite/tests/ghci/prog014/prog014.T b/testsuite/tests/ghci/prog014/prog014.T index d9dee7eac7..43481583c5 100644 --- a/testsuite/tests/ghci/prog014/prog014.T +++ b/testsuite/tests/ghci/prog014/prog014.T @@ -1,5 +1,6 @@ test('prog014', [extra_files(['Primop.hs', 'dummy.c']), extra_run_opts('dummy.o'), + expect_broken_for(15454, ['ghci']), pre_cmd('$MAKE -s --no-print-directory prog014')], ghci_script, ['prog014.script']) diff --git a/testsuite/tests/ghci/scripts/T15898.stderr b/testsuite/tests/ghci/scripts/T15898.stderr index 11ca6cc142..aeda5ba5fe 100644 --- a/testsuite/tests/ghci/scripts/T15898.stderr +++ b/testsuite/tests/ghci/scripts/T15898.stderr @@ -1,12 +1,4 @@ -<interactive>:3:1: error: - • Couldn't match kind ‘()’ with ‘*’ - When matching types - a0 :: * - '() :: () - • In the expression: undefined :: '() - In an equation for ‘it’: it = undefined :: '() - <interactive>:3:14: error: • Expected a type, but ‘'()’ has kind ‘()’ • In an expression type signature: '() @@ -19,34 +11,14 @@ In the expression: undefined :: Proxy '() Int In an equation for ‘it’: it = undefined :: Proxy '() Int -<interactive>:5:1: error: - • Couldn't match kind ‘[*]’ with ‘*’ - When matching types - a0 :: * - '[(), ()] :: [*] - • In the expression: undefined :: [(), ()] - In an equation for ‘it’: it = undefined :: [(), ()] - <interactive>:5:14: error: • Expected a type, but ‘[(), ()]’ has kind ‘[*]’ • In an expression type signature: [(), ()] In the expression: undefined :: [(), ()] In an equation for ‘it’: it = undefined :: [(), ()] -<interactive>:6:1: error: - • Couldn't match kind ‘([k0], [k1])’ with ‘*’ - When matching types - a0 :: * - '( '[], '[]) :: ([k0], [k1]) - • In the expression: undefined :: '( '[], '[]) - In an equation for ‘it’: it = undefined :: '( '[], '[]) - • Relevant bindings include - it :: '( '[], '[]) (bound at <interactive>:6:1) - <interactive>:6:14: error: • Expected a type, but ‘'( '[], '[])’ has kind ‘([k0], [k1])’ • In an expression type signature: '( '[], '[]) In the expression: undefined :: '( '[], '[]) In an equation for ‘it’: it = undefined :: '( '[], '[]) - • Relevant bindings include - it :: '( '[], '[]) (bound at <interactive>:6:1) diff --git a/testsuite/tests/ghci/scripts/T16509.hs b/testsuite/tests/ghci/scripts/T16509.hs new file mode 100644 index 0000000000..6f35e3c792 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T16509.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module PatternPanic where + +pattern TestPat :: (Int, Int) +pattern TestPat <- (isSameRef -> True, 0) + +isSameRef :: Int -> Bool +isSameRef e | 0 <- e = True +isSameRef _ = False diff --git a/testsuite/tests/ghci/scripts/T16509.script b/testsuite/tests/ghci/scripts/T16509.script new file mode 100644 index 0000000000..3e40de0b91 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T16509.script @@ -0,0 +1 @@ +:l T16509 diff --git a/testsuite/tests/ghci/scripts/T16563.script b/testsuite/tests/ghci/scripts/T16563.script new file mode 100644 index 0000000000..ce8711aece --- /dev/null +++ b/testsuite/tests/ghci/scripts/T16563.script @@ -0,0 +1 @@ +putStrLn "hello world" diff --git a/testsuite/tests/ghci/scripts/T16563.stdout b/testsuite/tests/ghci/scripts/T16563.stdout new file mode 100644 index 0000000000..9a71f81a4b --- /dev/null +++ b/testsuite/tests/ghci/scripts/T16563.stdout @@ -0,0 +1,2 @@ +hello world + diff --git a/testsuite/tests/ghci/scripts/T16767.script b/testsuite/tests/ghci/scripts/T16767.script new file mode 100644 index 0000000000..40d4812fed --- /dev/null +++ b/testsuite/tests/ghci/scripts/T16767.script @@ -0,0 +1,3 @@ +:set -fprint-explicit-foralls -fprint-explicit-kinds -XTypeApplications -XDataKinds +import Data.Proxy +:kind! 'Proxy @_ diff --git a/testsuite/tests/ghci/scripts/T16767.stdout b/testsuite/tests/ghci/scripts/T16767.stdout new file mode 100644 index 0000000000..340ed6ee80 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T16767.stdout @@ -0,0 +1,2 @@ +'Proxy @_ :: forall {k} {_ :: k}. Proxy @{k} _ += 'Proxy @{k} @_ diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index 5e4560a868..9dfcd6c0d6 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -21,9 +21,9 @@ instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ instance Semigroup () -- Defined in ‘GHC.Base’ +instance Enum () -- Defined in ‘GHC.Enum’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ -instance Enum () -- Defined in ‘GHC.Enum’ instance Bounded () -- Defined in ‘GHC.Enum’ type instance D () () = Bool -- Defined at T4175.hs:22:10 type instance D Int () = String -- Defined at T4175.hs:19:10 @@ -38,8 +38,8 @@ instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Maybe’ instance Semigroup a => Semigroup (Maybe a) -- Defined in ‘GHC.Base’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ -instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’ instance MonadFail Maybe -- Defined in ‘Control.Monad.Fail’ +instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’ instance Foldable Maybe -- Defined in ‘Data.Foldable’ instance Traversable Maybe -- Defined in ‘Data.Traversable’ type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15 @@ -47,11 +47,11 @@ data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’ instance [safe] C Int -- Defined at T4175.hs:18:10 instance Eq Int -- Defined in ‘GHC.Classes’ instance Ord Int -- Defined in ‘GHC.Classes’ -instance Show Int -- Defined in ‘GHC.Show’ -instance Read Int -- Defined in ‘GHC.Read’ instance Enum Int -- Defined in ‘GHC.Enum’ instance Num Int -- Defined in ‘GHC.Num’ instance Real Int -- Defined in ‘GHC.Real’ +instance Show Int -- Defined in ‘GHC.Show’ +instance Read Int -- Defined in ‘GHC.Read’ instance Bounded Int -- Defined in ‘GHC.Enum’ instance Integral Int -- Defined in ‘GHC.Real’ type instance D Int () = String -- Defined at T4175.hs:19:10 diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 8bf93a0d0f..a20f4896b0 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -3,9 +3,9 @@ instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ instance Semigroup () -- Defined in ‘GHC.Base’ +instance Enum () -- Defined in ‘GHC.Enum’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ -instance Enum () -- Defined in ‘GHC.Enum’ instance Bounded () -- Defined in ‘GHC.Enum’ data (##) :: TYPE ('GHC.Types.TupleRep '[]) = (##) -- Defined in ‘GHC.Prim’ diff --git a/testsuite/tests/ghci/scripts/T8469.stdout b/testsuite/tests/ghci/scripts/T8469.stdout index ec14842359..1a511e6b55 100644 --- a/testsuite/tests/ghci/scripts/T8469.stdout +++ b/testsuite/tests/ghci/scripts/T8469.stdout @@ -1,10 +1,10 @@ data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’ instance Eq Int -- Defined in ‘GHC.Classes’ instance Ord Int -- Defined in ‘GHC.Classes’ -instance Show Int -- Defined in ‘GHC.Show’ -instance Read Int -- Defined in ‘GHC.Read’ instance Enum Int -- Defined in ‘GHC.Enum’ instance Num Int -- Defined in ‘GHC.Num’ instance Real Int -- Defined in ‘GHC.Real’ +instance Show Int -- Defined in ‘GHC.Show’ +instance Read Int -- Defined in ‘GHC.Read’ instance Bounded Int -- Defined in ‘GHC.Enum’ instance Integral Int -- Defined in ‘GHC.Real’ diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 9ece912e1f..708bd9f8f9 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -106,7 +106,7 @@ test('ghci061', normal, ghci_script, ['ghci061.script']) test('ghci062', [extra_files(['ghci062/', 'ghci062/Test.hs']), when(config.have_ext_interp, extra_ways(['ghci-ext']))], ghci_script, ['ghci062.script']) -test('ghci063', when(opsys('darwin'), expect_broken(16201)), ghci_script, ['ghci063.script']) +test('ghci063', normal, ghci_script, ['ghci063.script']) test('T2452', [extra_hc_opts("-fno-implicit-import-qualified")], ghci_script, ['T2452.script']) @@ -295,4 +295,7 @@ test('T15941', normal, ghci_script, ['T15941.script']) test('T16030', normal, ghci_script, ['T16030.script']) test('T11606', normal, ghci_script, ['T11606.script']) test('T16089', normal, ghci_script, ['T16089.script']) +test('T16509', normal, ghci_script, ['T16509.script']) test('T16527', normal, ghci_script, ['T16527.script']) +test('T16563', extra_hc_opts("-clear-package-db -global-package-db"), ghci_script, ['T16563.script']) +test('T16767', normal, ghci_script, ['T16767.script']) diff --git a/testsuite/tests/ghci/scripts/ghci011.stdout b/testsuite/tests/ghci/scripts/ghci011.stdout index 112dde7811..6dd5782d6c 100644 --- a/testsuite/tests/ghci/scripts/ghci011.stdout +++ b/testsuite/tests/ghci/scripts/ghci011.stdout @@ -7,8 +7,8 @@ instance Monoid [a] -- Defined in ‘GHC.Base’ instance Ord a => Ord [a] -- Defined in ‘GHC.Classes’ instance Semigroup [a] -- Defined in ‘GHC.Base’ instance Show a => Show [a] -- Defined in ‘GHC.Show’ -instance Read a => Read [a] -- Defined in ‘GHC.Read’ instance MonadFail [] -- Defined in ‘Control.Monad.Fail’ +instance Read a => Read [a] -- Defined in ‘GHC.Read’ instance Foldable [] -- Defined in ‘Data.Foldable’ instance Traversable [] -- Defined in ‘Data.Traversable’ data () = () -- Defined in ‘GHC.Tuple’ @@ -16,9 +16,9 @@ instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ instance Semigroup () -- Defined in ‘GHC.Base’ +instance Enum () -- Defined in ‘GHC.Enum’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ -instance Enum () -- Defined in ‘GHC.Enum’ instance Bounded () -- Defined in ‘GHC.Enum’ data (,) a b = (,) a b -- Defined in ‘GHC.Tuple’ instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/ghci063.script b/testsuite/tests/ghci/scripts/ghci063.script index 87a19baf48..377f65934c 100644 --- a/testsuite/tests/ghci/scripts/ghci063.script +++ b/testsuite/tests/ghci/scripts/ghci063.script @@ -1,6 +1,18 @@ :! echo module A where {} >A.hs :! echo module B where { import A } >B.hs +-- Workaround for Trac #16201. We use "touch -r" to set modification +-- timestamps, which leads to precision loss on Darwin. For example, +-- +-- before: 2019-02-25 01:11:23.807627350 +0300 +-- after: 2019-02-25 01:11:23.807627000 +0300 +-- ^^^ +-- This means we can't trick GHCi into thinking the file hasn't been changed +-- by restoring its old timestamp, as we cannot faithfully restore all digits. +-- +-- The solution is to nullify the insignificant digits before the first load. +:! touch -r B.hs B.hs + :load B -- We're going to replace B.hs with an invalid module but without diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T index 43fe935e3e..e8f52a6334 100644 --- a/testsuite/tests/ghci/should_run/all.T +++ b/testsuite/tests/ghci/should_run/all.T @@ -36,7 +36,7 @@ test('T12549', just_ghci, ghci_script, ['T12549.script']) test('BinaryArray', normal, compile_and_run, ['']) test('T14125a', just_ghci, ghci_script, ['T14125a.script']) test('T13825-ghci',just_ghci, ghci_script, ['T13825-ghci.script']) -test('T14608', just_ghci, ghci_script, ['T14608.script']) +test('T14608', [just_ghci, expect_broken_for(15454, ['ghci'])], ghci_script, ['T14608.script']) test('T14963a', just_ghci, ghci_script, ['T14963a.script']) test('T14963b', just_ghci, ghci_script, ['T14963b.script']) test('T14963c', [extra_hc_opts("-fdefer-type-errors")], ghci_script, ['T14963c.script']) diff --git a/testsuite/tests/indexed-types/should_fail/T13877.stderr b/testsuite/tests/indexed-types/should_fail/T13877.stderr index 9dc8534ca1..674b258c24 100644 --- a/testsuite/tests/indexed-types/should_fail/T13877.stderr +++ b/testsuite/tests/indexed-types/should_fail/T13877.stderr @@ -1,25 +1,7 @@ -T13877.hs:65:17: error: - • Couldn't match type ‘Apply p (x : xs)’ with ‘p (x : xs)’ - Expected type: Sing x - -> Sing xs - -> App [a1] (':->) * p xs - -> App [a1] (':->) * p (x : xs) - Actual type: Sing x -> Sing xs -> (p @@ xs) -> p @@ (x : xs) - • In the expression: listElimPoly @(:->) @a @p @l - In an equation for ‘listElimTyFun’: - listElimTyFun = listElimPoly @(:->) @a @p @l - • Relevant bindings include - listElimTyFun :: Sing l - -> (p @@ '[]) - -> (forall (x :: a1) (xs :: [a1]). - Sing x -> Sing xs -> (p @@ xs) -> p @@ (x : xs)) - -> p @@ l - (bound at T13877.hs:65:1) - T13877.hs:65:41: error: • Expecting one more argument to ‘p’ - Expected kind ‘(-?>) [a1] * (':->)’, but ‘p’ has kind ‘[a1] ~> *’ + Expected kind ‘(-?>) [a] * (':->)’, but ‘p’ has kind ‘[a] ~> *’ • In the type ‘p’ In the expression: listElimPoly @(:->) @a @p @l In an equation for ‘listElimTyFun’: @@ -27,7 +9,7 @@ T13877.hs:65:41: error: • Relevant bindings include listElimTyFun :: Sing l -> (p @@ '[]) - -> (forall (x :: a1) (xs :: [a1]). + -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> (p @@ xs) -> p @@ (x : xs)) -> p @@ l (bound at T13877.hs:65:1) diff --git a/testsuite/tests/lib/base/T16586.hs b/testsuite/tests/lib/base/T16586.hs new file mode 100644 index 0000000000..37169e650a --- /dev/null +++ b/testsuite/tests/lib/base/T16586.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds, PolyKinds, RankNTypes, ScopedTypeVariables #-} + +module Main where + +import Data.Proxy +import GHC.TypeNats +import Numeric.Natural + +newtype Foo (m :: Nat) = Foo { getVal :: Word } + +mul :: KnownNat m => Foo m -> Foo m -> Foo m +mul mx@(Foo x) (Foo y) = + Foo $ x * y `rem` fromIntegral (natVal mx) + +pow :: KnownNat m => Foo m -> Int -> Foo m +pow x k = iterate (`mul` x) (Foo 1) !! k + +modl :: (forall m. KnownNat m => Foo m) -> Natural -> Word +modl x m = case someNatVal m of + SomeNat (_ :: Proxy m) -> getVal (x :: Foo m) + +-- Should print 1 +main :: IO () +main = print $ (Foo 127 `pow` 31336) `modl` 31337 + +dummyValue :: Word +dummyValue = (Foo 33 `pow` 44) `modl` 456 diff --git a/testsuite/tests/lib/base/T16586.stdout b/testsuite/tests/lib/base/T16586.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/lib/base/T16586.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/lib/base/all.T b/testsuite/tests/lib/base/all.T new file mode 100644 index 0000000000..ff0c9f963f --- /dev/null +++ b/testsuite/tests/lib/base/all.T @@ -0,0 +1 @@ +test('T16586', normal, compile_and_run, ['-O2']) diff --git a/testsuite/tests/partial-sigs/should_fail/T11976.stderr b/testsuite/tests/partial-sigs/should_fail/T11976.stderr index c4c3d50e59..0f218890b8 100644 --- a/testsuite/tests/partial-sigs/should_fail/T11976.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T11976.stderr @@ -1,17 +1,17 @@ -T11976.hs:7:7: error: - • Cannot instantiate unification variable ‘a0’ +T11976.hs:7:7: + Cannot instantiate unification variable ‘a0’ with a type involving foralls: Lens _3 _4 _5 GHC doesn't yet support impredicative polymorphism - • In the expression: undefined :: Lens _ _ _ + In the expression: undefined :: Lens _ _ _ In an equation for ‘foo’: foo = undefined :: Lens _ _ _ - • Relevant bindings include + Relevant bindings include foo :: Lens _ _1 _2 (bound at T11976.hs:7:1) -T11976.hs:7:20: error: - • Expected kind ‘k0 -> *’, but ‘Lens _ _’ has kind ‘*’ - • In the type ‘Lens _ _ _’ +T11976.hs:7:20: + Expected kind ‘k0 -> *’, but ‘Lens _ _’ has kind ‘*’ + In the type ‘Lens _ _ _’ In an expression type signature: Lens _ _ _ In the expression: undefined :: Lens _ _ _ - • Relevant bindings include + Relevant bindings include foo :: Lens _ _1 _2 (bound at T11976.hs:7:1) diff --git a/testsuite/tests/partial-sigs/should_fail/T12634.stderr b/testsuite/tests/partial-sigs/should_fail/T12634.stderr index 7aab25f5f8..3603ac1110 100644 --- a/testsuite/tests/partial-sigs/should_fail/T12634.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T12634.stderr @@ -1,31 +1,31 @@ -T12634.hs:14:19: error: - • Found type wildcard ‘_’ standing for ‘()’ +T12634.hs:14:19: + Found type wildcard ‘_’ standing for ‘()’ To use the inferred type, enable PartialTypeSignatures - • In the type signature: + In the type signature: bench_twacePow :: forall t m m' r. _ => t m' r -> Bench '(t, m, m', r) -T12634.hs:14:58: error: - • Expected a type, but +T12634.hs:14:58: + Expected a type, but ‘'(t, m, m', r)’ has kind ‘(* -> * -> *, *, *, *)’ - • In the first argument of ‘Bench’, namely ‘'(t, m, m', r)’ + In the first argument of ‘Bench’, namely ‘'(t, m, m', r)’ In the type ‘t m' r -> Bench '(t, m, m', r)’ In the type signature: bench_twacePow :: forall t m m' r. _ => t m' r -> Bench '(t, m, m', r) -T12634.hs:15:18: error: - • Couldn't match kind ‘(* -> * -> *, *, *, *)’ with ‘*’ +T12634.hs:15:18: + Couldn't match kind ‘(* -> * -> *, *, *, *)’ with ‘*’ When matching types params0 :: * '(t, m, m', r) :: (* -> * -> *, *, *, *) Expected type: t m' r -> Bench '(t, m, m', r) Actual type: t m' r -> Bench params0 - • In the expression: bench (twacePowDec :: t m' r -> t m r) + In the expression: bench (twacePowDec :: t m' r -> t m r) In an equation for ‘bench_twacePow’: bench_twacePow = bench (twacePowDec :: t m' r -> t m r) - • Relevant bindings include + Relevant bindings include bench_twacePow :: t m' r -> Bench '(t, m, m', r) (bound at T12634.hs:15:1) diff --git a/testsuite/tests/patsyn/should_fail/T15289.stderr b/testsuite/tests/patsyn/should_fail/T15289.stderr index 952d358692..64cc153ff8 100644 --- a/testsuite/tests/patsyn/should_fail/T15289.stderr +++ b/testsuite/tests/patsyn/should_fail/T15289.stderr @@ -1,10 +1,4 @@ -T15289.hs:5:16: error: - • Couldn't match expected type ‘Maybe’ with actual type ‘Bool’ - • In the pattern: True - In the pattern: True :: Maybe - In the declaration for pattern synonym ‘What’ - T15289.hs:5:24: error: • Expecting one more argument to ‘Maybe’ Expected a type, but ‘Maybe’ has kind ‘* -> *’ diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index b2ca109000..90a737c0b1 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -358,8 +358,11 @@ test('T13719', test('T14697', [ collect_compiler_stats('bytes allocated',10), - # This generates too large of a command-line for poor Windows - when(opsys('mingw32'), expect_broken(15072)), + # This generates too large of a command-line for poor Windows and + # Darwin. The failure is non-deterministic, so we 'skip' it rather than + # 'expect_broken'. The solution is to teach the testsuite driver to + # invoke GHC with a response file, see Trac #15072 + when(opsys('mingw32') or opsys('darwin'), skip), pre_cmd('./genT14697'), extra_files(['genT14697']), extra_hc_opts('$(cat T14697-flags)'), # 10k -optP arguments diff --git a/testsuite/tests/polykinds/T12593.stderr b/testsuite/tests/polykinds/T12593.stderr index e150299ea1..fcf194ba50 100644 --- a/testsuite/tests/polykinds/T12593.stderr +++ b/testsuite/tests/polykinds/T12593.stderr @@ -1,116 +1,11 @@ -T12593.hs:11:16: error: - • Expected kind ‘k0 -> k1 -> *’, but ‘Free k k1 k2 p’ has kind ‘*’ - • In the type signature: - run :: k2 q => - Free k k1 k2 p a b - -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - T12593.hs:12:31: error: • Expecting one more argument to ‘k’ Expected a type, but ‘k’ has kind - ‘(((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> *) - -> Constraint’ + ‘((k0 -> Constraint) -> k1 -> *) -> Constraint’ • In the kind ‘k’ In the type signature: run :: k2 q => Free k k1 k2 p a b -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - -T12593.hs:12:40: error: - • Expecting two more arguments to ‘k1’ - Expected a type, but - ‘k1’ has kind - ‘((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> *’ - • In the kind ‘k1’ - In the type signature: - run :: k2 q => - Free k k1 k2 p a b - -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - -T12593.hs:12:47: error: - • Couldn't match kind ‘(((k0 -> k1 -> *) -> Constraint) - -> (k3 -> k4 -> *) -> *) - -> Constraint’ - with ‘*’ - When matching kinds - k3 :: * - k6 :: (((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> *) - -> Constraint - • In the first argument of ‘p’, namely ‘c’ - In the type signature: - run :: k2 q => - Free k k1 k2 p a b - -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - -T12593.hs:12:49: error: - • Couldn't match kind ‘((k0 -> k1 -> *) -> Constraint) - -> (k3 -> k4 -> *) -> *’ - with ‘*’ - When matching kinds - k4 :: * - k7 :: ((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> * - • In the second argument of ‘p’, namely ‘d’ - In the type signature: - run :: k2 q => - Free k k1 k2 p a b - -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - -T12593.hs:12:56: error: - • Couldn't match kind ‘(((k0 -> k1 -> *) -> Constraint) - -> (k3 -> k4 -> *) -> *) - -> Constraint’ - with ‘*’ - When matching kinds - k0 :: * - k6 :: (((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> *) - -> Constraint - • In the first argument of ‘q’, namely ‘c’ - In the type signature: - run :: k2 q => - Free k k1 k2 p a b - -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - -T12593.hs:12:58: error: - • Couldn't match kind ‘((k0 -> k1 -> *) -> Constraint) - -> (k3 -> k4 -> *) -> *’ - with ‘*’ - When matching kinds - k1 :: * - k7 :: ((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> * - • In the second argument of ‘q’, namely ‘d’ - In the type signature: - run :: k2 q => - Free k k1 k2 p a b - -> (forall (c :: k) (d :: k1). p c d -> q c d) -> q a b - -T12593.hs:14:6: error: - • Couldn't match type ‘Free k2 p0’ with ‘Free k6 k7 k8 p’ - Expected type: Free k6 k7 k8 p a b - Actual type: Free k2 p0 a b - • In the pattern: Free cat - In an equation for ‘run’: run (Free cat) = cat - • Relevant bindings include - run :: Free k k4 k8 p a b - -> (forall (c :: k) (d :: k4). p c d -> q c d) -> q a b - (bound at T12593.hs:14:1) - -T12593.hs:14:18: error: - • Couldn't match kind ‘*’ - with ‘(((k3 -> k4 -> *) -> Constraint) -> (k3 -> k4 -> *) -> *) - -> Constraint’ - When matching kinds - k0 :: * - k6 :: (((k0 -> k1 -> *) -> Constraint) -> (k3 -> k4 -> *) -> *) - -> Constraint - • In the expression: cat - In an equation for ‘run’: run (Free cat) = cat - • Relevant bindings include - cat :: forall (q :: k0 -> k1 -> *). - k2 q => - (forall (c :: k0) (d :: k1). p0 c d -> q c d) -> q a b - (bound at T12593.hs:14:11) - run :: Free k k4 k8 p a b - -> (forall (c :: k) (d :: k4). p c d -> q c d) -> q a b - (bound at T12593.hs:14:1) diff --git a/testsuite/tests/polykinds/T15577.stderr b/testsuite/tests/polykinds/T15577.stderr index fef17090f8..5478da8b4a 100644 --- a/testsuite/tests/polykinds/T15577.stderr +++ b/testsuite/tests/polykinds/T15577.stderr @@ -7,65 +7,3 @@ T15577.hs:20:18: error: an equation for ‘g’: Refl <- f @f @a @r r In an equation for ‘g’: g r | Refl <- f @f @a @r r = Refl - -T15577.hs:20:21: error: - • Expected kind ‘f1 -> *’, but ‘a’ has kind ‘*’ - • In the type ‘a’ - In a stmt of a pattern guard for - an equation for ‘g’: - Refl <- f @f @a @r r - In an equation for ‘g’: g r | Refl <- f @f @a @r r = Refl - • Relevant bindings include - r :: Proxy r1 (bound at T15577.hs:18:3) - g :: Proxy r1 -> F r1 :~: r1 (bound at T15577.hs:18:1) - -T15577.hs:20:24: error: - • Couldn't match kind ‘* -> *’ with ‘*’ - When matching kinds - f1 :: * -> * - f1 a1 :: * - Expected kind ‘f1’, but ‘r’ has kind ‘f1 a1’ - • In the type ‘r’ - In a stmt of a pattern guard for - an equation for ‘g’: - Refl <- f @f @a @r r - In an equation for ‘g’: g r | Refl <- f @f @a @r r = Refl - • Relevant bindings include - r :: Proxy r1 (bound at T15577.hs:18:3) - g :: Proxy r1 -> F r1 :~: r1 (bound at T15577.hs:18:1) - -T15577.hs:20:26: error: - • Couldn't match kind ‘* -> *’ with ‘*’ - When matching kinds - f1 :: * -> * - a1 :: * - • In the fourth argument of ‘f’, namely ‘r’ - In a stmt of a pattern guard for - an equation for ‘g’: - Refl <- f @f @a @r r - In an equation for ‘g’: g r | Refl <- f @f @a @r r = Refl - • Relevant bindings include - r :: Proxy r1 (bound at T15577.hs:18:3) - g :: Proxy r1 -> F r1 :~: r1 (bound at T15577.hs:18:1) - -T15577.hs:21:7: error: - • Could not deduce: F r1 ~ r1 - from the context: r0 ~ F r0 - bound by a pattern with constructor: - Refl :: forall k (a :: k). a :~: a, - in a pattern binding in - a pattern guard for - an equation for ‘g’ - at T15577.hs:18:7-10 - ‘r1’ is a rigid type variable bound by - the type signature for: - g :: forall (f1 :: * -> *) a1 (r1 :: f1 a1). - Proxy r1 -> F r1 :~: r1 - at T15577.hs:17:1-76 - Expected type: F r1 :~: r1 - Actual type: r1 :~: r1 - • In the expression: Refl - In an equation for ‘g’: g r | Refl <- f @f @a @r r = Refl - • Relevant bindings include - r :: Proxy r1 (bound at T15577.hs:18:3) - g :: Proxy r1 -> F r1 :~: r1 (bound at T15577.hs:18:1) diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T index d7cd248848..cd92fccfba 100644 --- a/testsuite/tests/profiling/should_run/all.T +++ b/testsuite/tests/profiling/should_run/all.T @@ -88,7 +88,9 @@ test('prof-doc-fib', [], compile_and_run, ['']) test('prof-doc-last', [], compile_and_run, ['-fno-full-laziness']) # unicode in cost centre names -test('T5559', [], compile_and_run, ['']) +test('T5559', + [ skip # Skip due to non-deterministic failures on CI, see Trac #16350 + ], compile_and_run, ['']) # Note [consistent stacks] # Certain optimisations can change the stacks we get out of the diff --git a/testsuite/tests/rts/T16514.hs b/testsuite/tests/rts/T16514.hs new file mode 100644 index 0000000000..12e0d36221 --- /dev/null +++ b/testsuite/tests/rts/T16514.hs @@ -0,0 +1,18 @@ +-- ensure that the XMM register values are properly preserved across STG +-- exit/entry. Note that this is very sensitive to code generation. + +module Main where + +import Control.Monad (when) +import System.Exit (exitWith, ExitCode(..)) + +foreign export ccall fn_hs :: IO () + +fn_hs :: IO () +fn_hs = return () + +foreign import ccall test :: IO Int + +main :: IO () +main = do res <- test + when (res /= 0) (exitWith $ ExitFailure res) diff --git a/testsuite/tests/rts/T16514.stdout b/testsuite/tests/rts/T16514.stdout new file mode 100644 index 0000000000..6b582809d2 --- /dev/null +++ b/testsuite/tests/rts/T16514.stdout @@ -0,0 +1,4 @@ +1.414210 1.732050 2.236070 2.828430 3.605550 4.582580 +1.414210 1.732050 2.236070 2.828430 3.605550 4.582580 +1.414210 1.732050 2.236070 2.828430 3.605550 4.582580 + diff --git a/testsuite/tests/rts/T16514_c.cpp b/testsuite/tests/rts/T16514_c.cpp new file mode 100644 index 0000000000..1474741ec0 --- /dev/null +++ b/testsuite/tests/rts/T16514_c.cpp @@ -0,0 +1,45 @@ +#include <iostream> +#include <stdexcept> + +extern "C" { + +void fn_hs(); +void fn() { + fn_hs(); +} + +void check(double sqrt2, double sqrt3, double sqrt5, + double sqrt8, double sqrt13, double sqrt21) { + std::cout << std::fixed << sqrt2 << " " << sqrt3 << " " << sqrt5 << " " + << sqrt8 << " " << sqrt13 << " " << sqrt21 << std::endl; + if (sqrt2 != 1.41421 || sqrt3 != 1.73205 || sqrt5 != 2.23607 || + sqrt8 != 2.82843 || sqrt13 != 3.60555 || sqrt21 != 4.58258) { + throw std::runtime_error("xmm registers have been scratched"); + } +} + +int test() { + try { + double sqrt2 = 1.41421; + double sqrt3 = 1.73205; + double sqrt5 = 2.23607; + double sqrt8 = 2.82843; + double sqrt13 = 3.60555; + double sqrt21 = 4.58258; + check(sqrt2, sqrt3, sqrt5, sqrt8, sqrt13, sqrt21); + fn(); + check(sqrt2, sqrt3, sqrt5, sqrt8, sqrt13, sqrt21); + try { + fn(); + } catch (const std::exception &) { + } + check(sqrt2, sqrt3, sqrt5, sqrt8, sqrt13, sqrt21); + } catch (const std::exception &e) { + std::cerr << e.what() << std::endl; + return 1; + } + return 0; +} + +} // extern "C" + diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index ca8177c526..0bfad3ea87 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -106,9 +106,13 @@ test('atomicinc', [ c_src, only_ways(['normal','threaded1', 'threaded2']) ], com test('atomicxchg', [ c_src, only_ways(['threaded1', 'threaded2']) ], compile_and_run, ['']) -test('T3424', # it's slow: - [ when(fast(), skip), only_ways(['normal','threaded1','ghci']) ], - compile_and_run, ['']) +test('T3424', + [ # Skip due to non-deterministic timeouts on CI, see Trac #16349 + when(unregisterised(), skip), + # And it's slow in general + only_ways(['normal','threaded1','ghci']) + ], + compile_and_run, ['']) # Test for out-of-range heap size test('rtsflags001', [ only_ways(['normal']), exit_code(1), extra_run_opts('+RTS -H0m -RTS') ], compile_and_run, ['']) @@ -475,3 +479,4 @@ test('keep-cafs', run_command, ['$MAKE -s --no-print-directory KeepCafs']) +test('T16514', unless(opsys('mingw32'), skip), compile_and_run, ['T16514_c.cpp -lstdc++']) diff --git a/testsuite/tests/typecheck/should_compile/T16312.hs b/testsuite/tests/typecheck/should_compile/T16312.hs new file mode 100644 index 0000000000..1823d98558 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T16312.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +module T16312 where + +newtype Curried g h a = + Curried { runCurried :: forall r. g (a -> r) -> h r } + +instance Functor g => Functor (Curried g h) where + fmap f (Curried g) = Curried (g . fmap (.f)) + +instance (Functor g, g ~ h) => Applicative (Curried g h) where + pure a = Curried (fmap ($a)) + Curried mf <*> Curried ma = Curried (ma . mf . fmap (.)) + {-# INLINE (<*>) #-} diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 3c7737c115..c78c3f2cf8 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -669,3 +669,4 @@ test('T16188', normal, compile, ['']) test('T16204a', normal, compile, ['']) test('T16204b', normal, compile, ['']) test('T16225', normal, compile, ['']) +test('T16312', normal, compile, ['-O']) diff --git a/testsuite/tests/typecheck/should_fail/T11112.stderr b/testsuite/tests/typecheck/should_fail/T11112.stderr index 304078158e..db6e1822cb 100644 --- a/testsuite/tests/typecheck/should_fail/T11112.stderr +++ b/testsuite/tests/typecheck/should_fail/T11112.stderr @@ -2,12 +2,3 @@ T11112.hs:3:9: error: • Expected a type, but ‘Ord s’ has kind ‘Constraint’ • In the type signature: sort :: Ord s -> [s] -> [s] - -T11112.hs:4:11: error: - • Couldn't match expected type ‘[s] -> [s]’ - with actual type ‘Ord s’ - • In the expression: xs - In an equation for ‘sort’: sort xs = xs - • Relevant bindings include - xs :: Ord s (bound at T11112.hs:4:6) - sort :: Ord s => [s] -> [s] (bound at T11112.hs:4:1) diff --git a/testsuite/tests/typecheck/should_fail/T13819.stderr b/testsuite/tests/typecheck/should_fail/T13819.stderr index 89959cba39..917345f710 100644 --- a/testsuite/tests/typecheck/should_fail/T13819.stderr +++ b/testsuite/tests/typecheck/should_fail/T13819.stderr @@ -1,15 +1,4 @@ -T13819.hs:12:10: error: - • Couldn't match type ‘_0 -> A _0’ with ‘A a’ - Expected type: a -> A a - Actual type: (_1 -> WrappedMonad A _2) (_0 -> A _0) - • In the expression: pure @(_ -> WrappedMonad A _) @(_ -> A _) pure - In an equation for ‘pure’: - pure = pure @(_ -> WrappedMonad A _) @(_ -> A _) pure - In the instance declaration for ‘Applicative A’ - • Relevant bindings include - pure :: a -> A a (bound at T13819.hs:12:3) - T13819.hs:12:17: error: • Expected kind ‘* -> *’, but ‘_ -> WrappedMonad A _’ has kind ‘*’ • In the type ‘(_ -> WrappedMonad A _)’ diff --git a/testsuite/tests/typecheck/should_fail/T14232.stderr b/testsuite/tests/typecheck/should_fail/T14232.stderr index 1ca41f0bd5..a497be7b19 100644 --- a/testsuite/tests/typecheck/should_fail/T14232.stderr +++ b/testsuite/tests/typecheck/should_fail/T14232.stderr @@ -2,16 +2,3 @@ T14232.hs:3:6: error: • Expected kind ‘* -> *’, but ‘String -> a’ has kind ‘*’ • In the type signature: f :: (String -> a) String -> a - -T14232.hs:4:9: error: - • Couldn't match type ‘String -> a’ with ‘(->) t0’ - Expected type: t0 -> [Char] - Actual type: (String -> a) String - • The function ‘g’ is applied to one argument, - but its type ‘(String -> a) String’ has none - In the expression: g s - In an equation for ‘f’: f g s = g s - • Relevant bindings include - s :: t0 (bound at T14232.hs:4:5) - g :: (String -> a) String (bound at T14232.hs:4:3) - f :: (String -> a) String -> a (bound at T14232.hs:4:1) diff --git a/testsuite/tests/typecheck/should_fail/T15862.hs b/testsuite/tests/typecheck/should_fail/T15862.hs new file mode 100644 index 0000000000..6f8706560e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15862.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +module Bug where + +import Data.Kind +import Type.Reflection + +newtype Foo = MkFoo (forall a. a) + +foo :: TypeRep MkFoo +foo = typeRep @MkFoo + +type family F a +type instance F Int = Type + +data Bar = forall (a :: F Int). MkBar a + +bar :: TypeRep (MkBar True) +bar = typeRep + +data Quux = MkQuux (# Bool | Int #) + +quux :: TypeRep MkQuux +quux = typeRep + diff --git a/testsuite/tests/typecheck/should_fail/T15862.stderr b/testsuite/tests/typecheck/should_fail/T15862.stderr new file mode 100644 index 0000000000..22c3e12bdb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15862.stderr @@ -0,0 +1,21 @@ + +T15862.hs:17:7: error: + • No instance for (Typeable 'MkFoo) arising from a use of ‘typeRep’ + GHC can't yet do polykinded + Typeable ('MkFoo :: (forall a. a) -> Foo) + • In the expression: typeRep @MkFoo + In an equation for ‘foo’: foo = typeRep @MkFoo + +T15862.hs:25:7: error: + • No instance for (Typeable 'MkBar) arising from a use of ‘typeRep’ + GHC can't yet do polykinded Typeable ('MkBar :: Bool -> Bar) + • In the expression: typeRep + In an equation for ‘bar’: bar = typeRep + +T15862.hs:30:8: error: + • No instance for (Typeable 'MkQuux) + arising from a use of ‘typeRep’ + GHC can't yet do polykinded + Typeable ('MkQuux :: (# Bool | Int #) -> Quux) + • In the expression: typeRep + In an equation for ‘quux’: quux = typeRep diff --git a/testsuite/tests/typecheck/should_fail/T16517.hs b/testsuite/tests/typecheck/should_fail/T16517.hs new file mode 100644 index 0000000000..2664a18758 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T16517.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PolyKinds #-} +module T16517 where + +import Data.Proxy +class C a where m :: Proxy (a :: k) diff --git a/testsuite/tests/typecheck/should_fail/T16517.stderr b/testsuite/tests/typecheck/should_fail/T16517.stderr new file mode 100644 index 0000000000..8d20665afc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T16517.stderr @@ -0,0 +1,6 @@ + +T16517.hs:5:29: error: + • Expected kind ‘k’, but ‘a’ has kind ‘k0’ + • In the first argument of ‘Proxy’, namely ‘(a :: k)’ + In the type signature: m :: Proxy (a :: k) + In the class declaration for ‘C’ diff --git a/testsuite/tests/typecheck/should_fail/T3540.stderr b/testsuite/tests/typecheck/should_fail/T3540.stderr index eeb2c051f2..0fdb88b313 100644 --- a/testsuite/tests/typecheck/should_fail/T3540.stderr +++ b/testsuite/tests/typecheck/should_fail/T3540.stderr @@ -3,16 +3,6 @@ T3540.hs:4:12: error: • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ • In the type signature: thing :: (a ~ Int) -T3540.hs:5:9: error: - • Couldn't match kind ‘Constraint’ with ‘*’ - When matching types - a0 :: * - a ~ Int :: Constraint - • In the expression: undefined - In an equation for ‘thing’: thing = undefined - • Relevant bindings include - thing :: a ~ Int (bound at T3540.hs:5:1) - T3540.hs:7:20: error: • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ • In the type signature: thing1 :: Int -> (a ~ Int) diff --git a/testsuite/tests/typecheck/should_fail/T7778.stderr b/testsuite/tests/typecheck/should_fail/T7778.stderr index 1993b772e0..a0f10fcd92 100644 --- a/testsuite/tests/typecheck/should_fail/T7778.stderr +++ b/testsuite/tests/typecheck/should_fail/T7778.stderr @@ -1,10 +1,4 @@ -T7778.hs:3:6: error: - • Illegal qualified type: Num Int => Num - A constraint must be a monotype - Perhaps you intended to use QuantifiedConstraints - • In the type signature: v :: ((Num Int => Num) ()) => () - T7778.hs:3:7: error: • Expected kind ‘* -> Constraint’, but ‘Num Int => Num’ has kind ‘*’ diff --git a/testsuite/tests/typecheck/should_fail/T8806.stderr b/testsuite/tests/typecheck/should_fail/T8806.stderr index f0043a3edb..a0cc76ec46 100644 --- a/testsuite/tests/typecheck/should_fail/T8806.stderr +++ b/testsuite/tests/typecheck/should_fail/T8806.stderr @@ -1,10 +1,8 @@ T8806.hs:5:6: error: • Expected a constraint, but ‘Int’ has kind ‘*’ - • In the type signature: - f :: Int => Int + • In the type signature: f :: Int => Int T8806.hs:8:7: error: • Expected a constraint, but ‘Int’ has kind ‘*’ - • In the type signature: - g :: (Int => Show a) => Int + • In the type signature: g :: (Int => Show a) => Int diff --git a/testsuite/tests/typecheck/should_fail/VtaFail.stderr b/testsuite/tests/typecheck/should_fail/VtaFail.stderr index 6cb1f442a7..a9958016ce 100644 --- a/testsuite/tests/typecheck/should_fail/VtaFail.stderr +++ b/testsuite/tests/typecheck/should_fail/VtaFail.stderr @@ -25,17 +25,6 @@ VtaFail.hs:26:15: error: In the expression: first @Int F In an equation for ‘fInt’: fInt = first @Int F -VtaFail.hs:26:19: error: - • Couldn't match kind ‘*’ with ‘* -> *’ - When matching types - a1 :: * -> * - Int :: * - Expected type: First Int - Actual type: First a1 - • In the second argument of ‘first’, namely ‘F’ - In the expression: first @Int F - In an equation for ‘fInt’: fInt = first @Int F - VtaFail.hs:33:18: error: • Couldn't match type ‘Int’ with ‘Bool’ Expected type: Proxy Bool @@ -50,17 +39,6 @@ VtaFail.hs:40:17: error: In the expression: too @Maybe T In an equation for ‘threeBad’: threeBad = too @Maybe T -VtaFail.hs:40:23: error: - • Couldn't match kind ‘*’ with ‘k0 -> *’ - When matching types - a0 :: * -> k0 -> * - Maybe :: * -> * - Expected type: Three Maybe - Actual type: Three a0 - • In the second argument of ‘too’, namely ‘T’ - In the expression: too @Maybe T - In an equation for ‘threeBad’: threeBad = too @Maybe T - VtaFail.hs:41:27: error: • Couldn't match type ‘Either’ with ‘(->)’ Expected type: Three (->) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 2c09afa73e..b921a00e02 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -502,6 +502,7 @@ test('T15797', normal, compile_fail, ['']) test('T15799', normal, compile_fail, ['']) test('T15801', normal, compile_fail, ['']) test('T15816', normal, compile_fail, ['']) +test('T15862', normal, compile_fail, ['']) test('T16059a', normal, compile_fail, ['']) test('T16059c', [extra_files(['T16059b.hs'])], multimod_compile_fail, ['T16059c', '-v0']) @@ -511,3 +512,4 @@ test('T16059e', [extra_files(['T16059b.hs'])], multimod_compile_fail, ['T16059e', '-v0']) test('T16255', normal, compile_fail, ['']) test('T16204c', normal, compile_fail, ['']) +test('T16517', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail057.stderr b/testsuite/tests/typecheck/should_fail/tcfail057.stderr index 9ddffeb28b..4229e2fc38 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail057.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail057.stderr @@ -2,12 +2,3 @@ tcfail057.hs:5:7: error: • Expected a type, but ‘RealFrac a’ has kind ‘Constraint’ • In the type signature: f :: (RealFrac a) -> a -> a - -tcfail057.hs:6:7: error: - • Couldn't match expected type ‘a -> a’ - with actual type ‘RealFrac a’ - • In the expression: x - In an equation for ‘f’: f x = x - • Relevant bindings include - x :: RealFrac a (bound at tcfail057.hs:6:3) - f :: RealFrac a => a -> a (bound at tcfail057.hs:6:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail058.stderr b/testsuite/tests/typecheck/should_fail/tcfail058.stderr index 5150637cb9..a0ad07ea1f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail058.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail058.stderr @@ -3,23 +3,3 @@ tcfail058.hs:6:7: error: • Expecting one more argument to ‘Array a’ Expected a constraint, but ‘Array a’ has kind ‘* -> *’ • In the type signature: f :: (Array a) => a -> b - -tcfail058.hs:7:7: error: - • Could not deduce: a ~ b - from the context: Array a - bound by the type signature for: - f :: forall a b. Array a => a -> b - at tcfail058.hs:6:1-24 - ‘a’ is a rigid type variable bound by - the type signature for: - f :: forall a b. Array a => a -> b - at tcfail058.hs:6:1-24 - ‘b’ is a rigid type variable bound by - the type signature for: - f :: forall a b. Array a => a -> b - at tcfail058.hs:6:1-24 - • In the expression: x - In an equation for ‘f’: f x = x - • Relevant bindings include - x :: a (bound at tcfail058.hs:7:3) - f :: a -> b (bound at tcfail058.hs:7:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail063.stderr b/testsuite/tests/typecheck/should_fail/tcfail063.stderr index 7dd1e9ce02..a3347122e7 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail063.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail063.stderr @@ -3,20 +3,3 @@ tcfail063.hs:6:9: error: • Expecting one more argument to ‘Num’ Expected a constraint, but ‘Num’ has kind ‘* -> Constraint’ • In the type signature: moby :: Num => Int -> a -> Int - -tcfail063.hs:7:14: error: - • Could not deduce: a ~ Int - from the context: Num - bound by the type signature for: - moby :: forall a. Num => Int -> a -> Int - at tcfail063.hs:6:1-30 - ‘a’ is a rigid type variable bound by - the type signature for: - moby :: forall a. Num => Int -> a -> Int - at tcfail063.hs:6:1-30 - • In the second argument of ‘(+)’, namely ‘y’ - In the expression: x + y - In an equation for ‘moby’: moby x y = x + y - • Relevant bindings include - y :: a (bound at tcfail063.hs:7:8) - moby :: Int -> a -> Int (bound at tcfail063.hs:7:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail113.stderr b/testsuite/tests/typecheck/should_fail/tcfail113.stderr index 80c97d2737..fbdffa5ab9 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail113.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail113.stderr @@ -4,32 +4,11 @@ tcfail113.hs:12:7: error: Expected a type, but ‘Maybe’ has kind ‘* -> *’ • In the type signature: f :: [Maybe] -tcfail113.hs:13:1: error: - • Couldn't match expected type ‘[Maybe]’ - with actual type ‘p1 -> p1’ - • The equation(s) for ‘f’ have one argument, - but its type ‘[Maybe]’ has none - • Relevant bindings include - f :: [Maybe] (bound at tcfail113.hs:13:1) - tcfail113.hs:15:8: error: • Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ • In the first argument of ‘T’, namely ‘Int’ In the type signature: g :: T Int -tcfail113.hs:16:1: error: - • Couldn't match expected type ‘T Int’ with actual type ‘p0 -> p0’ - • The equation(s) for ‘g’ have one argument, - but its type ‘T Int’ has none - • Relevant bindings include g :: T Int (bound at tcfail113.hs:16:1) - tcfail113.hs:18:6: error: • Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ • In the type signature: h :: Int Int - -tcfail113.hs:19:1: error: - • Couldn't match type ‘Int’ with ‘(->) Int’ - Expected type: Int Int - Actual type: Int -> Int - • The equation(s) for ‘h’ have one argument, - but its type ‘Int Int’ has none diff --git a/testsuite/tests/typecheck/should_fail/tcfail134.stderr b/testsuite/tests/typecheck/should_fail/tcfail134.stderr index 8e1170cdfb..46ddc334bc 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail134.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail134.stderr @@ -2,6 +2,5 @@ tcfail134.hs:5:33: error: • Expecting one more argument to ‘XML’ Expected a type, but ‘XML’ has kind ‘* -> Constraint’ - • In the type signature: - toXML :: a -> XML + • In the type signature: toXML :: a -> XML In the class declaration for ‘XML’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail160.stderr b/testsuite/tests/typecheck/should_fail/tcfail160.stderr index 400b2bf5a4..96f2b4701c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail160.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail160.stderr @@ -3,9 +3,3 @@ tcfail160.hs:7:8: error: • Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ • In the first argument of ‘T’, namely ‘Int’ In the type signature: g :: T Int - -tcfail160.hs:8:1: error: - • Couldn't match expected type ‘T Int’ with actual type ‘p0 -> p0’ - • The equation(s) for ‘g’ have one argument, - but its type ‘T Int’ has none - • Relevant bindings include g :: T Int (bound at tcfail160.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail161.stderr b/testsuite/tests/typecheck/should_fail/tcfail161.stderr index 89042d1d20..b07d6031a6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail161.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail161.stderr @@ -3,11 +3,3 @@ tcfail161.hs:5:7: error: • Expecting one more argument to ‘Maybe’ Expected a type, but ‘Maybe’ has kind ‘* -> *’ • In the type signature: f :: [Maybe] - -tcfail161.hs:6:1: error: - • Couldn't match expected type ‘[Maybe]’ - with actual type ‘p0 -> p0’ - • The equation(s) for ‘f’ have one argument, - but its type ‘[Maybe]’ has none - • Relevant bindings include - f :: [Maybe] (bound at tcfail161.hs:6:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail212.stderr b/testsuite/tests/typecheck/should_fail/tcfail212.stderr index 8ceab3e931..ad5985e63a 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail212.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail212.stderr @@ -9,20 +9,6 @@ tcfail212.hs:10:14: error: Expected a type, but ‘Either Int’ has kind ‘* -> *’ • In the type signature: f :: (Maybe, Either Int) -tcfail212.hs:11:6: error: - • Couldn't match expected type ‘Maybe’ - with actual type ‘Maybe Integer’ - • In the expression: Just 1 - In the expression: (Just 1, Left 1) - In an equation for ‘f’: f = (Just 1, Left 1) - -tcfail212.hs:11:14: error: - • Couldn't match expected type ‘Either Int’ - with actual type ‘Either Integer b0’ - • In the expression: Left 1 - In the expression: (Just 1, Left 1) - In an equation for ‘f’: f = (Just 1, Left 1) - tcfail212.hs:13:7: error: • Expecting a lifted type, but ‘Int#’ is unlifted • In the type signature: g :: (Int#, Int#) @@ -30,3 +16,25 @@ tcfail212.hs:13:7: error: tcfail212.hs:13:13: error: • Expecting a lifted type, but ‘Int#’ is unlifted • In the type signature: g :: (Int#, Int#) + +tcfail212.hs:14:6: error: + • Couldn't match a lifted type with an unlifted type + When matching types + a :: * + Int# :: TYPE 'IntRep + • In the expression: 1# + In the expression: (1#, 2#) + In an equation for ‘g’: g = (1#, 2#) + • Relevant bindings include + g :: (a, b) (bound at tcfail212.hs:14:1) + +tcfail212.hs:14:10: error: + • Couldn't match a lifted type with an unlifted type + When matching types + b :: * + Int# :: TYPE 'IntRep + • In the expression: 2# + In the expression: (1#, 2#) + In an equation for ‘g’: g = (1#, 2#) + • Relevant bindings include + g :: (a, b) (bound at tcfail212.hs:14:1) diff --git a/utils/dump-interfaces.py b/utils/dump-interfaces.py new file mode 100644 index 0000000000..c5888ea286 --- /dev/null +++ b/utils/dump-interfaces.py @@ -0,0 +1,68 @@ +#!/usr/bin/env python + +""" +This is a handy utility for comparing the interfaces exposed by the core +library included in GHC's global package database. Given a compiler and a set +of packages it will produce a directory containing dumps of the :browse output +from each of the packages' exposed modules. These directories can be compared +with, e.g., meld with a reasonable number of false differences. +""" + +from pathlib import Path +import subprocess +from typing import TextIO, Set +import re + +CORE_PACKAGES = [ + "base", + "ghc-prim", + "template-haskell", + "ghc-boot", + "ghc-boot-th" +] + +exposed_modules_re = re.compile('exposed-modules:\s*((?:(?:[A-Z][A-Za-z0-9_]*\.)*(?:[A-Z][A-Za-z0-9_]*)\s*)*)') + +def dump_module(out: TextIO, ghc: Path, mod: str): + print(f' Dumping {mod}...') + subprocess.run([ghc, '--interactive', '-dppr-cols=9999', '-v0'], + input=f':bro {mod}', + stdout=out, + encoding='UTF-8', + check=True) + +def dump_package(out_dir: Path, ghc: Path, pkg: str): + pkg_out = out_dir / pkg + pkg_out.mkdir(exist_ok=True, parents=True) + + modules = get_modules(ghc, pkg) + print(f'Dumping {len(modules)} exposed modules from {pkg}...') + for mod in modules: + mod_out = pkg_out / f"{mod}.txt" + dump_module(mod_out.open('w'), ghc, mod) + +def get_modules(ghc: Path, pkg: str) -> Set[str]: + ghc_pkg = ghc.parent / "ghc-pkg" + out = subprocess.check_output([ghc_pkg, 'describe', pkg], encoding='UTF-8') + m = exposed_modules_re.search(out) + return set(m.group(1).split()) + +def main() -> None: + import argparse + parser = argparse.ArgumentParser() + parser.add_argument('-c', '--compiler', type=Path, required=True, + help='GHC executable') + parser.add_argument('-o', '--output', type=Path, default=Path('interfaces'), + help='Output directory') + parser.add_argument('package', nargs='*', help='Packages to dump') + args = parser.parse_args() + + packages = args.package + if packages == []: + packages = CORE_PACKAGES + + for pkg in packages: + dump_package(args.output, args.compiler, pkg) + +if __name__ == "__main__": + main() diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs index 190ec0edc0..1691bbaefb 100644 --- a/utils/genprimopcode/ParserM.hs +++ b/utils/genprimopcode/ParserM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module ParserM ( -- Parser Monad ParserM(..), AlexInput, run_parser, @@ -18,7 +19,13 @@ module ParserM ( ) where import Control.Applicative + +#if __GLASGOW_HASKELL__ >= 806 +import Prelude hiding (fail) +import Control.Monad.Fail (MonadFail (..)) +#else import Prelude +#endif import Control.Monad (ap, liftM) import Data.Word (Word8) @@ -42,6 +49,10 @@ instance Monad ParserM where Left err -> Left err return a = ParserM $ \i s -> Right (i, s, a) + +#if __GLASGOW_HASKELL__ >= 806 +instance MonadFail ParserM where +#endif fail err = ParserM $ \_ _ -> Left err run_parser :: ParserM a -> (String -> Either String a) diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 0782ead535..7f2cf91bb8 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -388,10 +388,11 @@ generate directory distdir config_args libraryDirs = forDeps Installed.libraryDirs -- The mkLibraryRelDir function is a bit of a hack. -- Ideally it should be handled in the makefiles instead. - mkLibraryRelDir "rts" = "rts/dist/build" - mkLibraryRelDir "ghc" = "compiler/stage2/build" - mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build" - mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build" + mkLibraryRelDir "rts" = "rts/dist/build" + mkLibraryRelDir "ghc" = "compiler/stage2/build" + mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build" + mkLibraryRelDir "containers" = "libraries/containers/containers/dist-install/build" + mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build" libraryRelDirs = map mkLibraryRelDir transitiveDepNames -- this is a hack to accommodate Cabal 2.2+ more hygenic diff --git a/utils/llvm-targets/gen-data-layout.sh b/utils/llvm-targets/gen-data-layout.sh index b0b411cb13..60cee202f8 100755 --- a/utils/llvm-targets/gen-data-layout.sh +++ b/utils/llvm-targets/gen-data-layout.sh @@ -29,7 +29,7 @@ TARGETS=( # Linux x86 "i386-unknown-linux-gnu" "i386-unknown-linux" "x86_64-unknown-linux-gnu" "x86_64-unknown-linux" # Linux Android - "armv7-unknown-linux-androideabi" "aarch64-unknown-linux-android" + "x86_64-unknown-linux-android" "armv7-unknown-linux-androideabi" "aarch64-unknown-linux-android" # Linux ppc64le "powerpc64le-unknown-linux" |