diff options
| author | Alejandro Serrano <trupill@gmail.com> | 2015-07-27 17:05:10 +0200 |
|---|---|---|
| committer | Alejandro Serrano <trupill@gmail.com> | 2015-07-27 17:05:10 +0200 |
| commit | a87bb2b35a9af784de688fe50cc2daea3090f5de (patch) | |
| tree | d240e225f7a0754f58302f25f79cecb409981775 | |
| parent | 6b05f0c574a5067cbd6db5909e34d66c3512aa8f (diff) | |
| parent | 474d4ccc6e4a3bea93be16cb7daef6ffcdf9b663 (diff) | |
| download | haskell-a87bb2b35a9af784de688fe50cc2daea3090f5de.tar.gz | |
Merge remote-tracking branch 'origin/master' into wip/impredicativity
Conflicts:
compiler/typecheck/Inst.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcRnTypes.hs
compiler/types/Unify.hs
337 files changed, 5970 insertions, 1963 deletions
diff --git a/.travis.yml b/.travis.yml index b283937455..4527708734 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,13 +16,13 @@ addons: - ubuntu-toolchain-r-test packages: - cabal-install-1.18 - - ghc-7.6.3 + - ghc-7.8.4 - alex-3.1.3 - happy-1.19.4 - llvm-3.6 before_install: - - export PATH=/opt/ghc/7.6.3/bin:/opt/cabal/1.18/bin:/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:/usr/lib/llvm-3.6/bin:$PATH + - export PATH=/opt/ghc/7.8.4/bin:/opt/cabal/1.18/bin:/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:/usr/lib/llvm-3.6/bin:$PATH # Be explicit about which protocol to use, such that we don't have to repeat the rewrite command for each. - git config remote.origin.url git://github.com/${TRAVIS_REPO_SLUG}.git @@ -47,7 +47,5 @@ script: # do not build dynamic libraries - echo 'DYNAMIC_GHC_PROGRAMS = NO' >> mk/validate.mk - echo 'GhcLibWays = v' >> mk/validate.mk - - if [ "$DEBUG_STAGE" = "YES" ]; then echo 'GhcStage2HcOpts += -DDEBUG' >> mk/validate.mk; fi - # Don't use --quiet, as it might cause the testsuite to not print output for - # over 10 minutes, causing Travis to kill our job. - - CPUS=2 SKIP_PERF_TESTS=YES ./validate --fast + - if [ "$DEBUG_STAGE2" = "YES" ]; then echo 'GhcStage2HcOpts += -DDEBUG' >> mk/validate.mk; fi + - THREADS=3 SKIP_PERF_TESTS=YES ./validate --fast --quiet diff --git a/compiler/backpack/ShPackageKey.hs b/compiler/backpack/ShPackageKey.hs new file mode 100644 index 0000000000..9fc44ae5cb --- /dev/null +++ b/compiler/backpack/ShPackageKey.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} +module ShPackageKey( + ShFreeHoles, + calcModuleFreeHoles, + + newPackageKey, + newPackageKeyWithScope, + lookupPackageKey, + + generalizeHoleModule, + canonicalizeModule, + + pprPackageKey +) where + +#include "HsVersions.h" + +import Module +import Packages +import FastString +import UniqFM +import UniqSet +import Outputable +import Util +import DynFlags + +import System.IO.Unsafe ( unsafePerformIO ) +import Control.Monad +import Numeric +import Data.IORef +import GHC.Fingerprint +import Data.Word +import qualified Data.Char as Char +import Data.List +import Data.Function + +-- NB: didn't put this in Module, that seems a bit too low in the +-- hierarchy, need to refer to DynFlags + +{- +************************************************************************ +* * + Package Keys +* * +************************************************************************ +-} + +-- Note: [PackageKey cache] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- The built-in PackageKey type (used by Module, Name, etc) +-- records the instantiation of the package as an MD5 hash +-- which is not reversible without some extra information. +-- However, the shape merging process requires us to be able +-- to substitute Module occurrences /inside/ the package key. +-- +-- Thus, we maintain the invariant: for every PackageKey +-- in our system, either: +-- +-- 1. It is in the installed package database (lookupPackage) +-- so we can lookup the recorded instantiatedWith +-- 2. We've recorded the associated mapping in the +-- PackageKeyCache. +-- +-- A PackageKey can be expanded into a ShPackageKey which has +-- the instance mapping. In the mapping, we don't bother +-- expanding a 'Module'; depending on 'shPackageKeyFreeHoles', +-- it may not be necessary to do a substitution (you only +-- need to drill down when substituing HOLE:H if H is in scope. + +-- Note: [Module name in scope set] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Similar to InScopeSet, ShFreeHoles is an optimization that +-- allows us to avoid expanding a PackageKey into an ShPackageKey +-- if there isn't actually anything in the module expression that +-- we can substitute. + +-- | Given a Name or Module, the 'ShFreeHoles' contains the set +-- of free variables, i.e. HOLE:A modules, which may be substituted. +-- If this set is empty no substitutions are possible. +type ShFreeHoles = UniqSet ModuleName + +-- | Calculate the free holes of a 'Module'. +calcModuleFreeHoles :: DynFlags -> Module -> IO ShFreeHoles +calcModuleFreeHoles dflags m + | modulePackageKey m == holePackageKey = return (unitUniqSet (moduleName m)) + | otherwise = do + shpk <- lookupPackageKey dflags (modulePackageKey m) + return $ case shpk of + ShDefinitePackageKey{} -> emptyUniqSet + ShPackageKey{ shPackageKeyFreeHoles = in_scope } -> in_scope + +-- | Calculate the free holes of the hole map @[('ModuleName', 'Module')]@. +calcInstsFreeHoles :: DynFlags -> [(ModuleName, Module)] -> IO ShFreeHoles +calcInstsFreeHoles dflags insts = + fmap unionManyUniqSets (mapM (calcModuleFreeHoles dflags . snd) insts) + +-- | Given a 'UnitName', a 'LibraryName', and sorted mapping of holes to +-- their implementations, compute the 'PackageKey' associated with it, as well +-- as the recursively computed 'ShFreeHoles' of holes that may be substituted. +newPackageKeyWithScope :: DynFlags + -> UnitName + -> LibraryName + -> [(ModuleName, Module)] + -> IO (PackageKey, ShFreeHoles) +newPackageKeyWithScope dflags pn vh insts = do + fhs <- calcInstsFreeHoles dflags insts + pk <- newPackageKey' dflags (ShPackageKey pn vh insts fhs) + return (pk, fhs) + +-- | Given a 'UnitName' and sorted mapping of holes to +-- their implementations, compute the 'PackageKey' associated with it. +-- (Analogous to 'newGlobalBinder'). +newPackageKey :: DynFlags + -> UnitName + -> LibraryName + -> [(ModuleName, Module)] + -> IO PackageKey +newPackageKey dflags pn vh insts = do + (pk, _) <- newPackageKeyWithScope dflags pn vh insts + return pk + +-- | Given a 'ShPackageKey', compute the 'PackageKey' associated with it. +-- This function doesn't calculate the 'ShFreeHoles', because it is +-- provided with 'ShPackageKey'. +newPackageKey' :: DynFlags -> ShPackageKey -> IO PackageKey +newPackageKey' _ (ShDefinitePackageKey pk) = return pk +newPackageKey' dflags + shpk@(ShPackageKey pn vh insts fhs) = do + ASSERTM( fmap (==fhs) (calcInstsFreeHoles dflags insts) ) + let pk = mkPackageKey pn vh insts + pkt_var = pkgKeyCache dflags + pk_cache <- readIORef pkt_var + let consistent pk_cache = maybe True (==shpk) (lookupUFM pk_cache pk) + MASSERT( consistent pk_cache ) + when (not (elemUFM pk pk_cache)) $ + atomicModifyIORef' pkt_var (\pk_cache -> + -- Could race, but it's guaranteed to be the same + ASSERT( consistent pk_cache ) (addToUFM pk_cache pk shpk, ())) + return pk + +-- | Given a 'PackageKey', reverse lookup the 'ShPackageKey' associated +-- with it. This only gives useful information for keys which are +-- created using 'newPackageKey' or the associated functions, or that are +-- already in the installed package database, since we generally cannot reverse +-- MD5 hashes. +lookupPackageKey :: DynFlags + -> PackageKey + -> IO ShPackageKey +lookupPackageKey dflags pk + | pk `elem` wiredInPackageKeys + || pk == mainPackageKey + || pk == holePackageKey + = return (ShDefinitePackageKey pk) + | otherwise = do + let pkt_var = pkgKeyCache dflags + pk_cache <- readIORef pkt_var + case lookupUFM pk_cache pk of + Just r -> return r + _ -> return (ShDefinitePackageKey pk) + +pprPackageKey :: PackageKey -> SDoc +pprPackageKey pk = sdocWithDynFlags $ \dflags -> + -- name cache is a memotable + let shpk = unsafePerformIO (lookupPackageKey dflags pk) + in case shpk of + shpk@ShPackageKey{} -> + ppr (shPackageKeyUnitName shpk) <> + parens (hsep + (punctuate comma [ ppUnless (moduleName m == modname) + (ppr modname <+> text "->") + <+> ppr m + | (modname, m) <- shPackageKeyInsts shpk])) + <> ifPprDebug (braces (ftext (packageKeyFS pk))) + ShDefinitePackageKey pk -> ftext (packageKeyFS pk) + +-- NB: newPackageKey and lookupPackageKey are mutually recursive; this +-- recursion is guaranteed to bottom out because you can't set up cycles +-- of PackageKeys. + + +{- +************************************************************************ +* * + Package key hashing +* * +************************************************************************ +-} + +-- | Generates a 'PackageKey'. Don't call this directly; you probably +-- want to cache the result. +mkPackageKey :: UnitName + -> LibraryName + -> [(ModuleName, Module)] -- hole instantiations + -> PackageKey +mkPackageKey (UnitName fsUnitName) + (LibraryName fsLibraryName) unsorted_holes = + -- NB: don't use concatFS here, it's not much of an improvement + fingerprintPackageKey . fingerprintString $ + unpackFS fsUnitName ++ "\n" ++ + unpackFS fsLibraryName ++ "\n" ++ + concat [ moduleNameString m + ++ " " ++ packageKeyString (modulePackageKey b) + ++ ":" ++ moduleNameString (moduleName b) ++ "\n" + | (m, b) <- sortBy (stableModuleNameCmp `on` fst) unsorted_holes] + +-- | Generalize a 'Module' into one where all the holes are indefinite. +-- @p(A -> ...):C@ generalizes to @p(A -> HOLE:A):C@. Useful when +-- you need to figure out if you've already type-checked the generalized +-- version of this module, so you don't have to do the whole rigamarole. +generalizeHoleModule :: DynFlags -> Module -> IO Module +generalizeHoleModule dflags m = do + pk <- generalizeHolePackageKey dflags (modulePackageKey m) + return (mkModule pk (moduleName m)) + +-- | Generalize a 'PackageKey' into one where all the holes are indefinite. +-- @p(A -> q():A) generalizes to p(A -> HOLE:A)@. +generalizeHolePackageKey :: DynFlags -> PackageKey -> IO PackageKey +generalizeHolePackageKey dflags pk = do + shpk <- lookupPackageKey dflags pk + case shpk of + ShDefinitePackageKey _ -> return pk + ShPackageKey { shPackageKeyUnitName = pn, + shPackageKeyLibraryName = vh, + shPackageKeyInsts = insts0 } + -> let insts = map (\(x, _) -> (x, mkModule holePackageKey x)) insts0 + in newPackageKey dflags pn vh insts + +-- | Canonicalize a 'Module' so that it uniquely identifies a module. +-- For example, @p(A -> M):A@ canonicalizes to @M@. Useful for making +-- sure the interface you've loaded as the right @mi_module@. +canonicalizeModule :: DynFlags -> Module -> IO Module +canonicalizeModule dflags m = do + let pk = modulePackageKey m + shpk <- lookupPackageKey dflags pk + return $ case shpk of + ShPackageKey { shPackageKeyInsts = insts } + | Just m' <- lookup (moduleName m) insts -> m' + _ -> m + +{- +************************************************************************ +* * + Base 62 +* * +************************************************************************ +-} + +-------------------------------------------------------------------------- +-- Base 62 + +-- The base-62 code is based off of 'locators' +-- ((c) Operational Dynamics Consulting, BSD3 licensed) + +-- Note: Instead of base-62 encoding a single 128-bit integer +-- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers +-- (2 * ceil(10.75) characters). Luckily for us, it's the same number of +-- characters! In the long term, this should go in GHC.Fingerprint, +-- but not now... + +-- | Size of a 64-bit word when written as a base-62 string +word64Base62Len :: Int +word64Base62Len = 11 + +-- | Converts a 64-bit word into a base-62 string +toBase62 :: Word64 -> String +toBase62 w = pad ++ str + where + pad = replicate len '0' + len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) + str = showIntAtBase 62 represent w "" + represent :: Int -> Char + represent x + | x < 10 = Char.chr (48 + x) + | x < 36 = Char.chr (65 + x - 10) + | x < 62 = Char.chr (97 + x - 36) + | otherwise = error ("represent (base 62): impossible!") + +fingerprintPackageKey :: Fingerprint -> PackageKey +fingerprintPackageKey (Fingerprint a b) + = stringToPackageKey (toBase62 a ++ toBase62 b) diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 5a7245828d..a70bcbdd3d 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -19,7 +19,7 @@ module DataCon ( buildAlgTyCon, -- ** Type deconstruction - dataConRepType, dataConSig, dataConFullSig, + dataConRepType, dataConSig, dataConInstSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConOrigTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, @@ -73,6 +73,7 @@ import qualified Data.Typeable import Data.Maybe import Data.Char import Data.Word +import Data.List( mapAccumL ) {- Data constructor representation @@ -857,6 +858,25 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) +dataConInstSig + :: DataCon + -> [Type] -- Instantiate the *universal* tyvars with these types + -> ([TyVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys +-- ^ Instantantiate the universal tyvars of a data con, +-- returning the instantiated existentials, constraints, and args +dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs + , dcEqSpec = eq_spec, dcOtherTheta = theta + , dcOrigArgTys = arg_tys }) + univ_tys + = (ex_tvs' + , substTheta subst (eqSpecPreds eq_spec ++ theta) + , substTys subst arg_tys) + where + univ_subst = zipTopTvSubst univ_tvs univ_tys + (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst ex_tvs + + -- | The \"full signature\" of the 'DataCon' returns, in order: -- -- 1) The result of 'dataConUnivTyVars' @@ -990,16 +1010,11 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool -- NB: look at *all* equality constraints, not only those -- in dataConEqSpec; see Trac #5168 dataConCannotMatch tys con - | null theta = False -- Common + | null inst_theta = False -- Common | all isTyVarTy tys = False -- Also common - | otherwise - = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2) - | (ty1, ty2) <- concatMap predEqs theta ] + | otherwise = typesCantMatch (concatMap predEqs inst_theta) where - dc_tvs = dataConUnivTyVars con - theta = dataConTheta con - subst = ASSERT2( length dc_tvs == length tys, ppr con $$ ppr dc_tvs $$ ppr tys ) - zipTopTvSubst dc_tvs tys + (_, inst_theta, _) = dataConInstSig con tys -- TODO: could gather equalities from superclasses too predEqs pred = case classifyPredType pred of diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index b942f4ecd5..bfb346efb3 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -15,7 +15,8 @@ module Demand ( mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, getUsage, toCleanDmd, absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, apply1Dmd, apply2Dmd, + lubDmd, bothDmd, + lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, isTopDmd, isBotDmd, isAbsDmd, isSeqDmd, peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, addCaseBndrDmd, @@ -522,10 +523,11 @@ mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as absDmd :: JointDmd absDmd = mkJointDmd Lazy Abs -apply1Dmd, apply2Dmd :: Demand +lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand -- C1(U), C1(C1(U)) respectively -apply1Dmd = JD { strd = Lazy, absd = Use Many (UCall One Used) } -apply2Dmd = JD { strd = Lazy, absd = Use Many (UCall One (UCall One Used)) } +strictApply1Dmd = JD { strd = Str (SCall HeadStr), absd = Use Many (UCall One Used) } +lazyApply1Dmd = JD { strd = Lazy, absd = Use Many (UCall One Used) } +lazyApply2Dmd = JD { strd = Lazy, absd = Use Many (UCall One (UCall One Used)) } topDmd :: JointDmd topDmd = mkJointDmd Lazy useTop diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 1564d6622e..4edf26831f 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -1086,7 +1086,6 @@ seqId = pcMiscPrelId seqName ty info ty = mkForAllTys [alphaTyVar,betaTyVar] (mkFunTy alphaTy (mkFunTy betaTy betaTy)) - -- NB argBetaTyVar; see Note [seqId magic] [x,y] = mkTemplateLocals [alphaTy, betaTy] rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) @@ -1102,8 +1101,15 @@ seqId = pcMiscPrelId seqName ty info match_seq_of_cast :: RuleFun -- See Note [Built-in RULES for seq] match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co] - = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, - scrut]) + = Just (fun `App` scrut) + where + fun = Lam x $ Lam y $ + Case (Var x) x res_ty [(DEFAULT,[],Var y)] + -- Generate a Case directly, not a call to seq, which + -- might be ill-kinded if res_ty is unboxed + [x,y] = mkTemplateLocals [scrut_ty, res_ty] + scrut_ty = pFst (coercionKind co) + match_seq_of_cast _ _ _ _ = Nothing ------------------------------------------------ @@ -1184,9 +1190,12 @@ Note [seqId magic] ~~~~~~~~~~~~~~~~~~ 'GHC.Prim.seq' is special in several ways. -a) Its second arg can have an unboxed type +a) In source Haskell its second arg can have an unboxed type x `seq` (v +# w) - Hence its second type variable has ArgKind + But see Note [Typing rule for seq] in TcExpr, which + explains why we give seq itself an ordinary type + seq :: forall a b. a -> b -> b + and treat it as a language construct from a typing point of view. b) Its fixity is set in LoadIface.ghcPrimIface @@ -1195,8 +1204,6 @@ c) It has quite a bit of desugaring magic. d) There is some special rule handing: Note [User-defined RULES for seq] -e) See Note [Typing rule for seq] in TcExpr. - Note [User-defined RULES for seq] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Roman found situations where he had @@ -1293,7 +1300,6 @@ Also see https://ghc.haskell.org/trac/ghc/wiki/OneShot. Note [magicDictId magic] ~~~~~~~~~~~~~~~~~~~~~~~~~ - The identifier `magicDict` is just a place-holder, which is used to implement a primitve that we cannot define in Haskell but we can write in Core. It is declared with a place-holder type: @@ -1327,15 +1333,14 @@ Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), which will replace the RHS of this definition with the appropriate definition in Core. The rewrite rule works as follows: -magicDict@t (wrap@a@b f) x y + magicDict @t (wrap @a @b f) x y ----> -f (x `cast` co a) y + f (x `cast` co a) y The `co` coercion is the newtype-coercion extracted from the type-class. The type class is obtain by looking at the type of wrap. - ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}. If things get nasty as-is, change it back to a literal (@Literal@). diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 88b6e68f97..ce8619a204 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -60,6 +60,7 @@ module Name ( isTyVarName, isTyConName, isDataConName, isValName, isVarName, isWiredInName, isBuiltInSyntax, + isHoleName, wiredInNameTyThing_maybe, nameIsLocalOrFrom, nameIsHomePackageImport, nameIsFromExternalPackage, stableNameCmp, @@ -212,6 +213,9 @@ isExternalName _ = False isInternalName name = not (isExternalName name) +isHoleName :: Name -> Bool +isHoleName = isHoleModule . nameModule + nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) nameModule_maybe :: Name -> Maybe Module nameModule_maybe (Name { n_sort = External mod}) = Just mod diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 0e9eb6d658..4b2bd96b52 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -212,8 +212,9 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload -- collector will ignore it. static_link_value | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 - | otherwise = mkIntCLit dflags 1 -- No CAF refs - + | otherwise = mkIntCLit dflags 3 -- No CAF refs + -- See Note [STATIC_LINK fields] + -- in rts/sm/Storage.h mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 563f6dcc4a..243e2a32ac 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -823,7 +823,8 @@ callishPrimOpSupported dflags op || llvm -> Left (MO_SubIntC (wordWidth dflags)) | otherwise -> Right genericIntSubCOp - WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) + WordMul2Op | ncg && x86ish + || llvm -> Left (MO_U_Mul2 (wordWidth dflags)) | otherwise -> Right genericWordMul2Op _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op) diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 688728ae48..f5f58dc442 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -175,7 +175,7 @@ expr_fvs (Type ty) = someVars (tyVarsOfType ty) expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) expr_fvs (Var var) = oneVar var expr_fvs (Lit _) = noVars -expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr +expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) @@ -279,9 +279,11 @@ ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) -- | Those variables free in the both the left right hand sides of a rule ruleFreeVars :: CoreRule -> VarSet ruleFreeVars (BuiltinRule {}) = noFVs -ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) +ruleFreeVars (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack] + , ru_bndrs = bndrs + , ru_rhs = rhs, ru_args = args }) = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet - -- See Note [Rule free var hack] + idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet -- Just the variables free on the *rhs* of a rule diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 41b6a9409a..b00e1ac141 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -25,6 +25,7 @@ module CoreLint ( import CoreSyn import CoreFVs import CoreUtils +import CoreStats ( coreBindsStats ) import CoreMonad import Bag import Literal @@ -209,7 +210,7 @@ dumpPassResult dflags unqual mb_flag hdr extra_info binds rules dump_doc = vcat [ nest 2 extra_info , size_doc , blankLine - , pprCoreBindings binds + , pprCoreBindingsWithSize binds , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine , ptext (sLit "------ Local rules for imported ids --------") diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs new file mode 100644 index 0000000000..9bd3f458b6 --- /dev/null +++ b/compiler/coreSyn/CoreSeq.hs @@ -0,0 +1,111 @@ +-- | +-- Various utilities for forcing Core structures +-- +-- It can often be useful to force various parts of the AST. This module +-- provides a number of @seq@-like functions to accomplish this. + +module CoreSeq ( + -- * Utilities for forcing Core structures + seqExpr, seqExprs, seqUnfolding, seqRules, + megaSeqIdInfo, seqSpecInfo, seqBinds, + ) where + +import CoreSyn +import IdInfo +import Demand( seqDemand, seqStrictSig ) +import BasicTypes( seqOccInfo ) +import VarSet( seqVarSet ) +import Var( varType, tyVarKind ) +import Type( seqType, isTyVar ) +import Coercion( seqCo ) +import Id( Id, idInfo ) + +-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the +-- compiler +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqSpecInfo (specInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqDemand (demandInfo info) `seq` + seqStrictSig (strictnessInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqOneShot (oneShotInfo info) `seq` + seqOccInfo (occInfo info) + +seqOneShot :: OneShotInfo -> () +seqOneShot l = l `seq` () + +seqSpecInfo :: SpecInfo -> () +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs + +seqCaf :: CafInfo -> () +seqCaf c = c `seq` () + +seqRules :: [CoreRule] -> () +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules + +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Cast e co) = seqExpr e `seq` seqCo co +seqExpr (Tick n e) = seqTickish n `seq` seqExpr e +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co + +seqExprs :: [CoreExpr] -> () +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqTickish :: Tickish Id -> () +seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () +seqTickish HpcTick{} = () +seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +seqTickish SourceNote{} = () + +seqBndr :: CoreBndr -> () +seqBndr b | isTyVar b = seqType (tyVarKind b) + | otherwise = seqType (varType b) `seq` + megaSeqIdInfo (idInfo b) + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBinds :: [Bind CoreBndr] -> () +seqBinds bs = foldr (seq . seqBind) () bs + +seqBind :: Bind CoreBndr -> () +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs :: [(CoreBndr, CoreExpr)] -> () +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts :: [CoreAlt] -> () +seqAlts [] = () +seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_work_free = b2, + uf_expandable = b3, uf_is_conlike = b4, + uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g + +seqUnfolding _ = () + +seqGuidance :: UnfoldingGuidance -> () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () diff --git a/compiler/coreSyn/CoreStats.hs b/compiler/coreSyn/CoreStats.hs new file mode 100644 index 0000000000..456943cce3 --- /dev/null +++ b/compiler/coreSyn/CoreStats.hs @@ -0,0 +1,128 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 +-} + +-- | Functions to computing the statistics reflective of the "size" +-- of a Core expression +module CoreStats ( + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, exprStats, + ) where + +import CoreSyn +import Outputable +import Coercion +import Var +import FastString (sLit) +import Type (Type, typeSize, seqType) +import Id (idType) +import CoreSeq (megaSeqIdInfo) + +data CoreStats = CS { cs_tm :: Int -- Terms + , cs_ty :: Int -- Types + , cs_co :: Int } -- Coercions + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) + = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, + ptext (sLit "types:") <+> intWithCommas i2 <> comma, + ptext (sLit "coercions:") <+> intWithCommas i3]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldr (plusCS . f) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS bindStats + +bindStats :: CoreBind -> CoreStats +bindStats (NonRec v r) = bindingStats v r +bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs + +bindingStats :: Var -> CoreExpr -> CoreStats +bindingStats v r = bndrStats v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b + `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Tick _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r + +altBndrStats :: [Var] -> CoreStats +-- Charge one for the alternative, not for each binder +altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } + +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = foldr ((+) . bindSize) 0 bs + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- It also forces the expression pretty drastically as a side effect +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var v) = v `seq` 1 +exprSize (Lit lit) = lit `seq` 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = bndrSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b t as) = seqType t `seq` + exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote cc _ _) = cc `seq` 1 +tickSize _ = 1 -- the rest are strict + +bndrSize :: Var -> Int +bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index c59ff2041d..3a821d5548 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -41,6 +41,7 @@ module CoreSubst ( import CoreSyn import CoreFVs +import CoreSeq import CoreUtils import Literal ( Literal(MachStr) ) import qualified Data.ByteString as BS diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index c641d88f65..fedf1d73ec 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -68,7 +68,7 @@ module CoreSyn ( deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, -- * Orphanhood - IsOrphan(..), isOrphan, notOrphan, + IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, -- * Core rule data types CoreRule(..), RuleBase, @@ -723,6 +723,21 @@ notOrphan :: IsOrphan -> Bool notOrphan NotOrphan{} = True notOrphan _ = False +chooseOrphanAnchor :: [Name] -> IsOrphan +-- Something (rule, instance) is relate to all the Names in this +-- list. Choose one of them to be an "anchor" for the orphan. We make +-- the choice deterministic to avoid gratuitious changes in the ABI +-- hash (Trac #4012). Specficially, use lexicographic comparison of +-- OccName rather than comparing Uniques +-- +-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically +-- +chooseOrphanAnchor local_names + | null local_names = IsOrphan + | otherwise = NotOrphan (minimum occs) + where + occs = map nameOccName local_names + instance Binary IsOrphan where put_ bh IsOrphan = putByte bh 0 put_ bh (NotOrphan n) = do diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index d1cbcbcba1..56de91c41b 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -29,10 +29,6 @@ module CoreUtils ( exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, - -- * Expression and bindings size - coreBindsSize, exprSize, - CoreStats(..), coreBindsStats, - -- * Equality cheapEqExpr, cheapEqExpr', eqExpr, diffExpr, diffBinds, @@ -40,10 +36,6 @@ module CoreUtils ( -- * Eta reduction tryEtaReduce, - -- * Seq - seqExpr, seqExprs, seqUnfolding, seqRules, - seqIdInfo, megaSeqIdInfo, seqSpecInfo, seqBinds, - -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg, dataConRepInstPat, dataConRepFSInstPat, @@ -67,8 +59,6 @@ import Name import Literal import DataCon import PrimOp -import Demand( seqDemand, seqStrictSig ) -import BasicTypes( seqOccInfo ) import Id import IdInfo import Type @@ -1786,221 +1776,6 @@ locBind loc b1 b2 diffs = map addLoc diffs {- ************************************************************************ * * -\subsection{Seq stuff} -* * -************************************************************************ --} - -seqExpr :: CoreExpr -> () -seqExpr (Var v) = v `seq` () -seqExpr (Lit lit) = lit `seq` () -seqExpr (App f a) = seqExpr f `seq` seqExpr a -seqExpr (Lam b e) = seqBndr b `seq` seqExpr e -seqExpr (Let b e) = seqBind b `seq` seqExpr e -seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as -seqExpr (Cast e co) = seqExpr e `seq` seqCo co -seqExpr (Tick n e) = seqTickish n `seq` seqExpr e -seqExpr (Type t) = seqType t -seqExpr (Coercion co) = seqCo co - -seqExprs :: [CoreExpr] -> () -seqExprs [] = () -seqExprs (e:es) = seqExpr e `seq` seqExprs es - -seqTickish :: Tickish Id -> () -seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () -seqTickish HpcTick{} = () -seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids -seqTickish SourceNote{} = () - -seqBndr :: CoreBndr -> () -seqBndr b | isTyVar b = seqType (tyVarKind b) - | otherwise = seqType (varType b) `seq` - megaSeqIdInfo (idInfo b) - -seqBndrs :: [CoreBndr] -> () -seqBndrs [] = () -seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs - -seqBinds :: [Bind CoreBndr] -> () -seqBinds bs = foldr (seq . seqBind) () bs - -seqBind :: Bind CoreBndr -> () -seqBind (NonRec b e) = seqBndr b `seq` seqExpr e -seqBind (Rec prs) = seqPairs prs - -seqPairs :: [(CoreBndr, CoreExpr)] -> () -seqPairs [] = () -seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs - -seqAlts :: [CoreAlt] -> () -seqAlts [] = () -seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts - -seqRules :: [CoreRule] -> () -seqRules [] = () -seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) - = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules -seqRules (BuiltinRule {} : rules) = seqRules rules - -seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, - uf_is_value = b1, uf_is_work_free = b2, - uf_expandable = b3, uf_is_conlike = b4, - uf_guidance = g}) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g - -seqUnfolding _ = () - -seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () -seqGuidance _ = () - --- | Just evaluate the 'IdInfo' to WHNF -seqIdInfo :: IdInfo -> () -seqIdInfo info = info `seq` () - --- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the --- compiler -megaSeqIdInfo :: IdInfo -> () -megaSeqIdInfo info - = seqSpecInfo (specInfo info) `seq` - --- Omitting this improves runtimes a little, presumably because --- some unfoldings are not calculated at all --- seqUnfolding (unfoldingInfo info) `seq` - - seqDemand (demandInfo info) `seq` - seqStrictSig (strictnessInfo info) `seq` - seqCaf (cafInfo info) `seq` - seqOneShot (oneShotInfo info) `seq` - seqOccInfo (occInfo info) - -seqOneShot :: OneShotInfo -> () -seqOneShot l = l `seq` () - -seqSpecInfo :: SpecInfo -> () -seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs - -seqCaf :: CafInfo -> () -seqCaf c = c `seq` () - -{- -************************************************************************ -* * -\subsection{The size of an expression} -* * -************************************************************************ --} - -data CoreStats = CS { cs_tm :: Int -- Terms - , cs_ty :: Int -- Types - , cs_co :: Int } -- Coercions - - -instance Outputable CoreStats where - ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) - = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, - ptext (sLit "types:") <+> intWithCommas i2 <> comma, - ptext (sLit "coercions:") <+> intWithCommas i3]) - -plusCS :: CoreStats -> CoreStats -> CoreStats -plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) - (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) - = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } - -zeroCS, oneTM :: CoreStats -zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } -oneTM = zeroCS { cs_tm = 1 } - -sumCS :: (a -> CoreStats) -> [a] -> CoreStats -sumCS f = foldr (plusCS . f) zeroCS - -coreBindsStats :: [CoreBind] -> CoreStats -coreBindsStats = sumCS bindStats - -bindStats :: CoreBind -> CoreStats -bindStats (NonRec v r) = bindingStats v r -bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs - -bindingStats :: Var -> CoreExpr -> CoreStats -bindingStats v r = bndrStats v `plusCS` exprStats r - -bndrStats :: Var -> CoreStats -bndrStats v = oneTM `plusCS` tyStats (varType v) - -exprStats :: CoreExpr -> CoreStats -exprStats (Var {}) = oneTM -exprStats (Lit {}) = oneTM -exprStats (Type t) = tyStats t -exprStats (Coercion c) = coStats c -exprStats (App f a) = exprStats f `plusCS` exprStats a -exprStats (Lam b e) = bndrStats b `plusCS` exprStats e -exprStats (Let b e) = bindStats b `plusCS` exprStats e -exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as -exprStats (Cast e co) = coStats co `plusCS` exprStats e -exprStats (Tick _ e) = exprStats e - -altStats :: CoreAlt -> CoreStats -altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r - -altBndrStats :: [Var] -> CoreStats --- Charge one for the alternative, not for each binder -altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs - -tyStats :: Type -> CoreStats -tyStats ty = zeroCS { cs_ty = typeSize ty } - -coStats :: Coercion -> CoreStats -coStats co = zeroCS { cs_co = coercionSize co } - -coreBindsSize :: [CoreBind] -> Int --- We use coreBindStats for user printout --- but this one is a quick and dirty basis for --- the simplifier's tick limit -coreBindsSize bs = foldr ((+) . bindSize) 0 bs - -exprSize :: CoreExpr -> Int --- ^ A measure of the size of the expressions, strictly greater than 0 --- It also forces the expression pretty drastically as a side effect --- Counts *leaves*, not internal nodes. Types and coercions are not counted. -exprSize (Var v) = v `seq` 1 -exprSize (Lit lit) = lit `seq` 1 -exprSize (App f a) = exprSize f + exprSize a -exprSize (Lam b e) = bndrSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b t as) = seqType t `seq` exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e -exprSize (Tick n e) = tickSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 -exprSize (Coercion co) = seqCo co `seq` 1 - -tickSize :: Tickish Id -> Int -tickSize (ProfNote cc _ _) = cc `seq` 1 -tickSize _ = 1 -- the rest are strict - -bndrSize :: Var -> Int -bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1 - | otherwise = seqType (idType b) `seq` - megaSeqIdInfo (idInfo b) `seq` - 1 - -bndrsSize :: [Var] -> Int -bndrsSize = sum . map bndrSize - -bindSize :: CoreBind -> Int -bindSize (NonRec b e) = bndrSize b + exprSize e -bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs - -pairSize :: (Var, CoreExpr) -> Int -pairSize (b,e) = bndrSize b + exprSize e - -altSize :: CoreAlt -> Int -altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e - -{- -************************************************************************ -* * Eta reduction * * ************************************************************************ diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index c0af96886d..2ae1577bd0 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -10,10 +10,12 @@ Printing of Core syntax module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprCoreBindingWithSize, pprCoreBindingsWithSize, pprRules ) where import CoreSyn +import CoreStats (exprStats) import Literal( pprLiteral ) import Name( pprInfixName, pprPrefixName ) import Var @@ -46,11 +48,17 @@ pprCoreBinding :: OutputableBndr b => Bind b -> SDoc pprCoreExpr :: OutputableBndr b => Expr b -> SDoc pprParendExpr :: OutputableBndr b => Expr b -> SDoc -pprCoreBindings = pprTopBinds -pprCoreBinding = pprTopBind +pprCoreBindings = pprTopBinds noAnn +pprCoreBinding = pprTopBind noAnn + +pprCoreBindingsWithSize :: [CoreBind] -> SDoc +pprCoreBindingWithSize :: CoreBind -> SDoc + +pprCoreBindingsWithSize = pprTopBinds sizeAnn +pprCoreBindingWithSize = pprTopBind sizeAnn instance OutputableBndr b => Outputable (Bind b) where - ppr bind = ppr_bind bind + ppr bind = ppr_bind noAnn bind instance OutputableBndr b => Outputable (Expr b) where ppr expr = pprCoreExpr expr @@ -63,32 +71,47 @@ instance OutputableBndr b => Outputable (Expr b) where ************************************************************************ -} -pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc -pprTopBinds binds = vcat (map pprTopBind binds) +-- | A function to produce an annotation for a given right-hand-side +type Annotation b = Expr b -> SDoc + +-- | Annotate with the size of the right-hand-side +sizeAnn :: CoreExpr -> SDoc +sizeAnn e = ptext (sLit "-- RHS size:") <+> ppr (exprStats e) + +-- | No annotation +noAnn :: Expr b -> SDoc +noAnn _ = empty + +pprTopBinds :: OutputableBndr a + => Annotation a -- ^ generate an annotation to place before the + -- binding + -> [Bind a] -- ^ bindings to show + -> SDoc -- ^ the pretty result +pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) -pprTopBind :: OutputableBndr a => Bind a -> SDoc -pprTopBind (NonRec binder expr) - = ppr_binding (binder,expr) $$ blankLine +pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc +pprTopBind ann (NonRec binder expr) + = ppr_binding ann (binder,expr) $$ blankLine -pprTopBind (Rec []) +pprTopBind _ (Rec []) = ptext (sLit "Rec { }") -pprTopBind (Rec (b:bs)) +pprTopBind ann (Rec (b:bs)) = vcat [ptext (sLit "Rec {"), - ppr_binding b, - vcat [blankLine $$ ppr_binding b | b <- bs], + ppr_binding ann b, + vcat [blankLine $$ ppr_binding ann b | b <- bs], ptext (sLit "end Rec }"), blankLine] -ppr_bind :: OutputableBndr b => Bind b -> SDoc +ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc -ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) -ppr_bind (Rec binds) = vcat (map pp binds) - where - pp bind = ppr_binding bind <> semi +ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) +ppr_bind ann (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding ann bind <> semi -ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc -ppr_binding (val_bdr, expr) - = pprBndr LetBind val_bdr $$ +ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc +ppr_binding ann (val_bdr, expr) + = ann expr $$ pprBndr LetBind val_bdr $$ hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) pprParendExpr expr = ppr_expr parens expr @@ -97,6 +120,12 @@ pprCoreExpr expr = ppr_expr noParens expr noParens :: SDoc -> SDoc noParens pp = pp +pprOptCo :: Coercion -> SDoc +pprOptCo co = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressCoercions dflags + then ptext (sLit "...") + else parens (sep [ppr co, dcolon <+> ppr (coercionType co)]) + ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) @@ -107,16 +136,7 @@ ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) - = add_par $ - sep [pprParendExpr expr, - ptext (sLit "`cast`") <+> pprCo co] - where - pprCo co = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressCoercions dflags - then ptext (sLit "...") - else parens $ - sep [ppr co, dcolon <+> ppr (coercionType co)] - + = add_par $ sep [pprParendExpr expr, ptext (sLit "`cast`") <+> pprOptCo co] ppr_expr add_par expr@(Lam _ _) = let @@ -210,7 +230,7 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) -- General case (recursive case, too) ppr_expr add_par (Let bind expr) = add_par $ - sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), + sep [hang (ptext keyword) 2 (ppr_bind noAnn bind <+> ptext (sLit "} in")), pprCoreExpr expr] where keyword = case bind of @@ -248,7 +268,7 @@ pprArg (Type ty) if gopt Opt_SuppressTypeApplications dflags then empty else ptext (sLit "@") <+> pprParendType ty -pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co +pprArg (Coercion co) = ptext (sLit "@~") <+> pprOptCo co pprArg expr = pprParendExpr expr {- @@ -338,9 +358,8 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressIdInfo dflags - then empty - else info `seq` doc -- The seq is useful for poking on black holes + ppUnless (gopt Opt_SuppressIdInfo dflags) $ + info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info occ_info = occInfo info @@ -368,9 +387,7 @@ pprIdBndrInfo info ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressIdInfo dflags - then empty - else + ppUnless (gopt Opt_SuppressIdInfo dflags) $ showAttributes [ (True, pp_scope <> ppr (idDetails id)) , (has_arity, ptext (sLit "Arity=") <> int arity) @@ -455,7 +472,9 @@ instance Outputable Unfolding where , ptext (sLit "WorkFree=") <> ppr wf , ptext (sLit "Expandable=") <> ppr exp , ptext (sLit "Guidance=") <> ppr g ] - pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs + pp_tmpl = sdocWithDynFlags $ \dflags -> + ppUnless (gopt Opt_SuppressUnfoldings dflags) $ + ptext (sLit "Tmpl=") <+> ppr rhs pp_rhs | isStableSource src = pp_tmpl | otherwise = empty -- Don't print the RHS or we get a quadratic diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index e3a31b9caa..9d751fcd0a 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -168,7 +168,7 @@ deSugar hsc_env ; let mod_guts = ModGuts { mg_module = mod, - mg_boot = hsc_src == HsBootFile, + mg_hsc_src = hsc_src, mg_exports = exports, mg_deps = deps, mg_used_names = used_names, diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 70bc6908f7..d4a811ff1b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -58,6 +58,7 @@ import ForeignCall import Util import MonadUtils +import Data.ByteString ( unpack ) import Data.Maybe import Control.Monad import Data.List @@ -488,12 +489,14 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _))) conv_cimportspec (CFunction (StaticTarget _ _ _ False)) = panic "conv_cimportspec: values not supported yet" conv_cimportspec CWrapper = return "wrapper" + -- these calling conventions do not support headers and the static keyword + raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv static = case cis of - CFunction (StaticTarget _ _ _ _) -> "static " + CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " _ -> "" chStr = case mch of - Nothing -> "" - Just (Header _ h) -> unpackFS h ++ " " + Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " + _ -> "" repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) @@ -846,11 +849,26 @@ repLTy :: LHsType Name -> DsM (Core TH.TypeQ) repLTy (L _ ty) = repTy ty repTy :: HsType Name -> DsM (Core TH.TypeQ) -repTy (HsForAllTy _ _ tvs ctxt ty) = +repTy (HsForAllTy _ extra tvs ctxt ty) = addTyVarBinds tvs $ \bndrs -> do - ctxt1 <- repLContext ctxt + ctxt1 <- repLContext ctxt' ty1 <- repLTy ty repTForall bndrs ctxt1 ty1 + where + -- If extra is not Nothing, an extra-constraints wild card was removed + -- (just) before renaming. It must be put back now, otherwise the + -- represented type won't include this extra-constraints wild card. + ctxt' + | Just loc <- extra + = let uniq = panic "addExtraCtsWC" + -- This unique will be discarded by repLContext, but is required + -- to make a Name + name = mkInternalName uniq (mkTyVarOcc "_") loc + in (++ [L loc (HsWildCardTy (AnonWildCard name))]) `fmap` ctxt + | otherwise + = ctxt + + repTy (HsTyVar n) | isTvOcc occ = do tv1 <- lookupOcc n @@ -909,11 +927,10 @@ repTy (HsExplicitTupleTy _ tys) = do repTy (HsTyLit lit) = do lit' <- repTyLit lit repTLit lit' -repTy (HsWildCardTy wc) = do - let name = HsSyn.wildCardName wc - putSrcSpanDs (nameSrcSpan name) $ - failWithDs $ text "Unexpected wild card:" <+> - quotes (ppr name) +repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard +repTy (HsWildCardTy (NamedWildCard n)) = do + nwc <- lookupOcc n + repTNamedWildCard nwc repTy ty = notHandled "Exotic form of type" (ppr ty) @@ -1909,6 +1926,13 @@ repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ) repTLit (MkC lit) = rep2 litTName [lit] +repTWildCard :: DsM (Core TH.TypeQ) +repTWildCard = rep2 wildCardTName [] + +repTNamedWildCard :: Core TH.Name -> DsM (Core TH.TypeQ) +repTNamedWildCard (MkC s) = rep2 namedWildCardTName [s] + + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -1984,6 +2008,13 @@ repKConstraint = rep2 constraintKName [] -- Literals repLiteral :: HsLit -> DsM (Core TH.Lit) +repLiteral (HsStringPrim _ bs) + = do dflags <- getDynFlags + word8_ty <- lookupType word8TyConName + let w8s = unpack bs + w8s_expr = map (\w8 -> mkCoreConApps word8DataCon + [mkWordLit dflags (toInteger w8)]) w8s + rep2 stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit = do lit' <- case lit of HsIntPrim _ i -> mk_integer i @@ -1991,6 +2022,7 @@ repLiteral lit HsInt _ i -> mk_integer i HsFloatPrim r -> mk_rational r HsDoublePrim r -> mk_rational r + HsCharPrim _ c -> mk_char c _ -> return lit lit_expr <- dsLit lit' case mb_lit_name of @@ -2005,6 +2037,7 @@ repLiteral lit HsFloatPrim _ -> Just floatPrimLName HsDoublePrim _ -> Just doublePrimLName HsChar _ _ -> Just charLName + HsCharPrim _ _ -> Just charPrimLName HsString _ _ -> Just stringLName HsRat _ _ -> Just rationalLName _ -> Nothing @@ -2018,6 +2051,9 @@ mk_rational r = do rat_ty <- lookupType rationalTyConName mk_string :: FastString -> DsM HsLit mk_string s = return $ HsString "" s +mk_char :: Char -> DsM HsLit +mk_char c = return $ HsChar "" c + repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) = do { lit <- mk_lit val; repLiteral lit } diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 61beca2f5c..ad6a6b1d7b 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -184,7 +184,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside else do { ; result <- liftIO $ findImportedModule hsc_env modname Nothing ; case result of - Found _ mod -> loadModule err mod + FoundModule h -> loadModule err (fr_mod h) _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err } } diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 38e92f89d6..28227f32bf 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -124,6 +124,7 @@ Library cbits/genSym.c hs-source-dirs: + backpack basicTypes cmm codeGen @@ -259,6 +260,8 @@ Library CoreTidy CoreUnfold CoreUtils + CoreSeq + CoreStats MkCore PprCore Check @@ -498,6 +501,7 @@ Library Vectorise Hoopl.Dataflow Hoopl + ShPackageKey -- CgInfoTbls used in ghci/DebuggerUtils -- CgHeapery mkVirtHeapOffsets used in ghci diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 0c02f49999..e1634fda28 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -490,6 +490,8 @@ compiler_stage2_dll0_MODULES = \ CoreTidy \ CoreUnfold \ CoreUtils \ + CoreSeq \ + CoreStats \ CostCentre \ Ctype \ DataCon \ diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 8c2a07c07f..c5fe7139fc 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -562,23 +562,29 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable + -- compilation) we may need to use maybe_getFileLinkable. + -- If the module is actually a signature, there won't be a + -- linkable (thus catMaybes) ; let { osuf = objectSuf dflags } - ; lnks_needed <- mapM (get_linkable osuf) mods_needed + ; lnks_needed <- fmap Maybes.catMaybes + $ mapM (get_linkable osuf) mods_needed ; return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. - follow_deps :: [Module] -- modules to follow - -> UniqSet ModuleName -- accum. module dependencies - -> UniqSet PackageKey -- accum. package dependencies + -- | Given a list of modules @mods@, recursively discover all external + -- package and local module (according to @this_pkg@) dependencies. + -- + -- The 'ModIface' contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqSet ModuleName -- accum. module dependencies + -> UniqSet PackageKey -- accum. package dependencies -> IO ([ModuleName], [PackageKey]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) @@ -601,6 +607,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods where is_boot (m,True) = Left m is_boot (m,False) = Right m + -- Boot module dependencies which must be processed recursively boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps @@ -631,30 +638,37 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods get_linkable osuf mod_name -- A home-package module | Just mod_info <- lookupUFM hpt mod_name - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + = adjust_linkable (hm_iface mod_info) + (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... + -- ezyang: I don't actually know how to trigger this codepath, + -- seeing as this is GHCi logic. Template Haskell, maybe? mb_stuff <- findHomeModule hsc_env mod_name case mb_stuff of - Found loc mod -> found loc mod + FoundExact loc mod -> found loc mod _ -> no_obj mod_name where found loc mod = do { -- ...and then find the linkable for it mb_lnk <- findObjectLinkableMaybe mod loc ; + iface <- initIfaceCheck hsc_env $ + loadUserInterface False (text "getLinkDeps2") mod ; case mb_lnk of { Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk + Just lnk -> adjust_linkable iface lnk }} - adjust_linkable lnk + adjust_linkable iface lnk + -- Signatures have no linkables! Don't return one. + | mi_hsc_src iface == HsigFile = return Nothing | Just new_osuf <- replace_osuf = do new_uls <- mapM (adjust_ul new_osuf) (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } + return (Just lnk{ linkableUnlinked=new_uls }) | otherwise = - return lnk + return (Just lnk) adjust_ul new_osuf (DotO file) = do MASSERT(osuf `isSuffixOf` file) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index da7fcdeae1..4a0e013cf9 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -473,16 +473,25 @@ noExistentials = [] cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) cvtForD (ImportF callconv safety from nm ty) + -- the prim and javascript calling conventions do not support headers + -- and are inserted verbatim, analogous to mkImport in RdrHsSyn + | callconv == TH.Prim || callconv == TH.JavaScript + = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing + (CFunction (StaticTarget from (mkFastString from) Nothing + True)) + (noLoc from)) | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') (mkFastString (TH.nameBase nm)) from (noLoc from) - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) - } + = mk_imp impspec | otherwise = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent") where + mk_imp impspec + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) + } safety' = case safety of Unsafe -> PlayRisky Safe -> PlaySafe @@ -880,6 +889,7 @@ cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar (show c) c } +cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' ; return $ HsString s s' } @@ -1029,6 +1039,12 @@ cvtTypeKind ty_str ty LitT lit -> returnL (HsTyLit (cvtTyLit lit)) + WildCardT Nothing + -> mk_apps mkAnonWildCardTy tys' + + WildCardT (Just nm) + -> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' } + PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' } -- Promoted data constructor; hence cName diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 9233f4fde1..79b0deeb16 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -981,16 +981,17 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys - , con_res = ResTyGADT _ res_ty }) - = ppr_con_names cons <+> dcolon <+> + , con_res = ResTyGADT _ res_ty, con_doc = doc }) + = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] where mk_fun_ty a b = noLoc (HsFunTy a b) pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = RecCon fields - , con_res = ResTyGADT _ res_ty }) - = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt, + , con_res = ResTyGADT _ res_ty, con_doc = doc }) + = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + <+> pprHsForAll expl tvs cxt, pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty] pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index 4b9f968ebf..eb9d23a9ed 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -3,9 +3,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} -#if __GLASGOW_HASKELL__ > 706 {-# LANGUAGE RoleAnnotations #-} -#endif module HsExpr where @@ -15,31 +13,21 @@ import {-# SOURCE #-} HsPat ( LPat ) import PlaceHolder ( DataId ) import Data.Data hiding ( Fixity ) -#if __GLASGOW_HASKELL__ > 706 type role HsExpr nominal type role HsCmd nominal type role MatchGroup nominal representational type role GRHSs nominal representational type role HsSplice nominal -#endif data HsExpr (i :: *) data HsCmd (i :: *) data HsSplice (i :: *) data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) -#if __GLASGOW_HASKELL__ > 706 instance Typeable HsSplice instance Typeable HsExpr instance Typeable MatchGroup instance Typeable GRHSs -#else -instance Typeable1 HsSplice -instance Typeable1 HsExpr -instance Typeable1 HsCmd -instance Typeable2 MatchGroup -instance Typeable2 GRHSs -#endif instance (DataId id) => Data (HsSplice id) instance (DataId id) => Data (HsExpr id) diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index 114425b526..c6ab5a5b35 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -3,9 +3,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} -#if __GLASGOW_HASKELL__ > 706 {-# LANGUAGE RoleAnnotations #-} -#endif module HsPat where import SrcLoc( Located ) @@ -14,17 +12,11 @@ import Data.Data hiding (Fixity) import Outputable import PlaceHolder ( DataId ) -#if __GLASGOW_HASKELL__ > 706 type role Pat nominal -#endif data Pat (i :: *) type LPat i = Located (Pat i) -#if __GLASGOW_HASKELL__ > 706 instance Typeable Pat -#else -instance Typeable1 Pat -#endif instance (DataId id) => Data (Pat id) instance (OutputableBndr name) => Outputable (Pat name) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 9b8639369c..9526a8cce3 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -34,7 +34,8 @@ module HsTypes ( ConDeclField(..), LConDeclField, pprConDeclFields, HsWildCardInfo(..), mkAnonWildCardTy, mkNamedWildCardTy, - wildCardName, sameWildCard, isAnonWildCard, isNamedWildCard, + wildCardName, sameWildCard, sameNamedWildCard, + isAnonWildCard, isNamedWildCard, mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, @@ -682,6 +683,12 @@ sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 sameWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2 sameWildCard _ _ = False +sameNamedWildCard :: Eq name + => Located (HsWildCardInfo name) + -> Located (HsWildCardInfo name) -> Bool +sameNamedWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2 +sameNamedWildCard _ _ = False + splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index 1bd931674f..a822b100e9 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -151,7 +151,10 @@ newImplicitBinder base_name mk_sys_occ ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = return exports -lookupOrig :: Module -> OccName -> TcRnIf a b Name +-- | Look up the 'Name' for a given 'Module' and 'OccName'. +-- Consider alternately using 'lookupIfaceTop' if you're in the 'IfL' monad +-- and 'Module' is simply that of the 'ModIface' you are typechecking. +lookupOrig :: Module -> OccName -> TcRnIf a b Name lookupOrig mod occ = do { -- First ensure that mod and occ are evaluated -- If not, chaos can ensue: diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 4e3f9d6d0a..9d95b485f3 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -15,6 +15,10 @@ module IfaceType ( IfaceTyLit(..), IfaceTcArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, + -- Equality testing + IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes, + eqIfaceTcArgs, eqIfaceTvBndrs, eqIfaceCoercion, + -- Conversion from Type -> IfaceType toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, toIfaceContext, toIfaceBndr, toIfaceIdBndr, @@ -50,7 +54,6 @@ import TcType import DynFlags import TypeRep import Unique( hasKey ) -import Util ( filterOut, zipWithEqual ) import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Id @@ -65,6 +68,8 @@ import Binary import Outputable import FastString import UniqSet +import UniqFM +import Util import Data.Maybe( fromMaybe ) {- @@ -120,6 +125,7 @@ type IfaceContext = [IfacePredType] data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString + deriving (Eq) -- See Note [Suppressing kinds] -- We use a new list type (rather than [(IfaceType,Bool)], because @@ -137,12 +143,14 @@ data IfaceTcArgs -- properly. data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName , ifaceTyConInfo :: IfaceTyConInfo } + deriving (Eq) data IfaceTyConInfo -- Used to guide pretty-printing -- and to disambiguate D from 'D (they share a name) = NoIfaceTyConInfo | IfacePromotedDataCon | IfacePromotedTyCon + deriving (Eq) data IfaceCoercion = IfaceReflCo Role IfaceType @@ -269,6 +277,136 @@ substIfaceTyVar env tv {- ************************************************************************ * * + Equality over IfaceTypes +* * +************************************************************************ +-} + +-- Like an RnEnv2, but mapping from FastString to deBruijn index +-- DeBruijn; see eqTypeX +type BoundVar = Int +data IfRnEnv2 + = IRV2 { ifenvL :: UniqFM BoundVar -- from FastString + , ifenvR :: UniqFM BoundVar + , ifenv_next :: BoundVar + } + +emptyIfRnEnv2 :: IfRnEnv2 +emptyIfRnEnv2 = IRV2 { ifenvL = emptyUFM + , ifenvR = emptyUFM + , ifenv_next = 0 } + +rnIfOccL :: IfRnEnv2 -> IfLclName -> Maybe BoundVar +rnIfOccL env = lookupUFM (ifenvL env) + +rnIfOccR :: IfRnEnv2 -> IfLclName -> Maybe BoundVar +rnIfOccR env = lookupUFM (ifenvR env) + +extendIfRnEnv2 :: IfRnEnv2 -> IfLclName -> IfLclName -> IfRnEnv2 +extendIfRnEnv2 IRV2 { ifenvL = lenv + , ifenvR = renv + , ifenv_next = n } tv1 tv2 + = IRV2 { ifenvL = addToUFM lenv tv1 n + , ifenvR = addToUFM renv tv2 n + , ifenv_next = n + 1 + } + +eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool +eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) = + case (rnIfOccL env tv1, rnIfOccR env tv2) of + (Just v1, Just v2) -> v1 == v2 + (Nothing, Nothing) -> tv1 == tv2 + _ -> False +eqIfaceType _ (IfaceLitTy l1) (IfaceLitTy l2) = l1 == l2 +eqIfaceType env (IfaceAppTy t11 t12) (IfaceAppTy t21 t22) + = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 +eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22) + = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 +eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22) + = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 +eqIfaceType env (IfaceForAllTy (tv1, k1) t1) (IfaceForAllTy (tv2, k2) t2) + = eqIfaceType env k1 k2 && eqIfaceType (extendIfRnEnv2 env tv1 tv2) t1 t2 +eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2) + = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2 +eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2) + = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2 +eqIfaceType _ _ _ = False + +eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool +eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2) + +eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool +eqIfaceTcArgs _ ITC_Nil ITC_Nil = True +eqIfaceTcArgs env (ITC_Type ty1 tys1) (ITC_Type ty2 tys2) + = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2 +eqIfaceTcArgs env (ITC_Kind ty1 tys1) (ITC_Kind ty2 tys2) + = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2 +eqIfaceTcArgs _ _ _ = False + +-- | Similar to 'eqTyVarBndrs', checks that tyvar lists +-- are the same length and have matching kinds; if so, extend the +-- 'IfRnEnv2'. Returns 'Nothing' if they don't match. +eqIfaceTvBndrs :: IfRnEnv2 -> [IfaceTvBndr] -> [IfaceTvBndr] -> Maybe IfRnEnv2 +eqIfaceTvBndrs env [] [] = Just env +eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2) + | eqIfaceType env k1 k2 + = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2 +eqIfaceTvBndrs _ _ _ = Nothing + +-- coreEqCoercion2 +eqIfaceCoercion :: IfRnEnv2 -> IfaceCoercion -> IfaceCoercion -> Bool +eqIfaceCoercion env (IfaceReflCo eq1 ty1) (IfaceReflCo eq2 ty2) + = eq1 == eq2 && eqIfaceType env ty1 ty2 +eqIfaceCoercion env (IfaceFunCo eq1 co11 co12) (IfaceFunCo eq2 co21 co22) + = eq1 == eq2 && eqIfaceCoercion env co11 co21 + && eqIfaceCoercion env co12 co22 +eqIfaceCoercion env (IfaceTyConAppCo eq1 tc1 cos1) (IfaceTyConAppCo eq2 tc2 cos2) + = eq1 == eq2 && tc1 == tc2 && all2 (eqIfaceCoercion env) cos1 cos2 +eqIfaceCoercion env (IfaceAppCo co11 co12) (IfaceAppCo co21 co22) + = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22 + +eqIfaceCoercion env (IfaceForAllCo (v1,k1) co1) (IfaceForAllCo (v2,k2) co2) + = eqIfaceType env k1 k2 && + eqIfaceCoercion (extendIfRnEnv2 env v1 v2) co1 co2 + +eqIfaceCoercion env (IfaceCoVarCo cv1) (IfaceCoVarCo cv2) + = rnIfOccL env cv1 == rnIfOccR env cv2 + +eqIfaceCoercion env (IfaceAxiomInstCo con1 ind1 cos1) + (IfaceAxiomInstCo con2 ind2 cos2) + = con1 == con2 + && ind1 == ind2 + && all2 (eqIfaceCoercion env) cos1 cos2 + +-- the provenance string is just a note, so don't use in comparisons +eqIfaceCoercion env (IfaceUnivCo _ r1 ty11 ty12) (IfaceUnivCo _ r2 ty21 ty22) + = r1 == r2 && eqIfaceType env ty11 ty21 && eqIfaceType env ty12 ty22 + +eqIfaceCoercion env (IfaceSymCo co1) (IfaceSymCo co2) + = eqIfaceCoercion env co1 co2 + +eqIfaceCoercion env (IfaceTransCo co11 co12) (IfaceTransCo co21 co22) + = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22 + +eqIfaceCoercion env (IfaceNthCo d1 co1) (IfaceNthCo d2 co2) + = d1 == d2 && eqIfaceCoercion env co1 co2 +eqIfaceCoercion env (IfaceLRCo d1 co1) (IfaceLRCo d2 co2) + = d1 == d2 && eqIfaceCoercion env co1 co2 + +eqIfaceCoercion env (IfaceInstCo co1 ty1) (IfaceInstCo co2 ty2) + = eqIfaceCoercion env co1 co2 && eqIfaceType env ty1 ty2 + +eqIfaceCoercion env (IfaceSubCo co1) (IfaceSubCo co2) + = eqIfaceCoercion env co1 co2 + +eqIfaceCoercion env (IfaceAxiomRuleCo a1 ts1 cs1) (IfaceAxiomRuleCo a2 ts2 cs2) + = a1 == a2 && all2 (eqIfaceType env) ts1 ts2 && all2 (eqIfaceCoercion env) cs1 cs2 + +eqIfaceCoercion _ _ _ = False + +{- +************************************************************************ +* * Functions over IFaceTcArgs * * ************************************************************************ diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 2a8943ca11..9da1175a5d 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -234,26 +234,61 @@ needWiredInHomeIface _ = False ************************************************************************ -} +-- Note [Un-ambiguous multiple interfaces] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When a user writes an import statement, this usually causes a *single* +-- interface file to be loaded. However, the game is different when +-- signatures are being imported. Suppose in packages p and q we have +-- signatures: +-- +-- module A where +-- foo :: Int +-- +-- module A where +-- bar :: Int +-- +-- If both packages are exposed and I am importing A, I should see a +-- "unified" signature: +-- +-- module A where +-- foo :: Int +-- bar :: Int +-- +-- The way we achieve this is having the module lookup for A load and return +-- multiple interface files, which we will then process as if there were +-- "multiple" imports: +-- +-- import "p" A +-- import "q" A +-- +-- Doing so does not cause any ambiguity, because any overlapping identifiers +-- are guaranteed to have the same name if the backing implementations of the +-- two signatures are the same (a condition which is checked by 'Packages'.) + + -- | Load the interface corresponding to an @import@ directive in -- source code. On a failure, fail in the monad with an error message. +-- See Note [Un-ambiguous multiple interfaces] for why the return type +-- is @[ModIface]@ loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> Maybe FastString -- "package", if any - -> RnM ModIface + -> RnM [ModIface] loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc err - Succeeded iface -> return iface } + Failed err -> failWithTc err + Succeeded ifaces -> return ifaces } --- | Like 'loadSrcInterface', but returns a 'MaybeErr'. +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. See also +-- Note [Un-ambiguous multiple interfaces] loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> Maybe FastString -- "package", if any - -> RnM (MaybeErr MsgDoc ModIface) + -> RnM (MaybeErr MsgDoc [ModIface]) loadSrcInterface_maybe doc mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -264,7 +299,15 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg = do { hsc_env <- getTopEnv ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg ; case res of - Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) + FoundModule (FoundHs { fr_mod = mod }) + -> fmap (fmap (:[])) + . initIfaceTcRn + $ loadInterface doc mod (ImportByUser want_boot) + FoundSigs mods _backing + -> initIfaceTcRn $ do + ms <- forM mods $ \(FoundHs { fr_mod = mod }) -> + loadInterface doc mod (ImportByUser want_boot) + return (sequence ms) err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) } -- | Load interface directly for a fully qualified 'Module'. (This is a fairly @@ -542,20 +585,18 @@ loadDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)] loadDecls ignore_prags ver_decls - = do { mod <- getIfModule - ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls + = do { thingss <- mapM (loadDecl ignore_prags) ver_decls ; return (concat thingss) } loadDecl :: Bool -- Don't load pragmas into the decl pool - -> Module -> (Fingerprint, IfaceDecl) -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the -- TyThings are forkM'd thunks -loadDecl ignore_prags mod (_version, decl) +loadDecl ignore_prags (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl - main_name <- lookupOrig mod (ifName decl) + main_name <- lookupIfaceTop (ifName decl) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -628,7 +669,7 @@ loadDecl ignore_prags mod (_version, decl) Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) - ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) + ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) -- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) ; return $ (main_name, thing) : @@ -704,7 +745,7 @@ findAndReadIface doc_str mod hi_boot_file hsc_env <- getTopEnv mb_found <- liftIO (findExactModule hsc_env mod) case mb_found of - Found loc mod -> do + FoundExact loc mod -> do -- Found file, so read it let file_path = addBootSuffix_maybe hi_boot_file @@ -721,7 +762,8 @@ findAndReadIface doc_str mod hi_boot_file traceIf (ptext (sLit "...not found")) dflags <- getDynFlags return (Failed (cannotFindInterface dflags - (moduleName mod) err)) + (moduleName mod) + (convFindExactResult err))) where read_file file_path = do traceIf (ptext (sLit "readIFace") <+> text file_path) read_result <- readIface mod file_path @@ -867,7 +909,7 @@ pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface = vcat [ ptext (sLit "interface") - <+> ppr (mi_module iface) <+> pp_boot + <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else Outputable.empty) <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else Outputable.empty) <+> (if mi_hpc iface then ptext (sLit "[hpc]") else Outputable.empty) @@ -896,8 +938,9 @@ pprModIface iface , pprTrustPkg (mi_trust_pkg iface) ] where - pp_boot | mi_boot iface = ptext (sLit "[boot]") - | otherwise = Outputable.empty + pp_hsc_src HsBootFile = ptext (sLit "[boot]") + pp_hsc_src HsigFile = ptext (sLit "[hsig]") + pp_hsc_src HsSrcFile = Outputable.empty {- When printing export lists, we print like this: diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 970031327c..753c81a8a0 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -142,7 +142,7 @@ mkIface :: HscEnv mkIface hsc_env maybe_old_fingerprint mod_details ModGuts{ mg_module = this_mod, - mg_boot = is_boot, + mg_hsc_src = hsc_src, mg_used_names = used_names, mg_used_th = used_th, mg_deps = deps, @@ -156,7 +156,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details mg_dependent_files = dependent_files } = mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names used_th deps rdr_env fix_env + this_mod hsc_src used_names used_th deps rdr_env fix_env warns hpc_info dir_imp_mods self_trust dependent_files safe_mode mod_details @@ -187,7 +187,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files) mkIface_ hsc_env maybe_old_fingerprint - this_mod (hsc_src == HsBootFile) used_names + this_mod hsc_src used_names used_th deps rdr_env fix_env warns hpc_info (imp_mods imports) (imp_trust_own_pkg imports) dep_files safe_mode mod_details @@ -231,7 +231,7 @@ mkDependencies -- sort to get into canonical order -- NB. remember to use lexicographic ordering -mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface +mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> Bool @@ -240,7 +240,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> ModDetails -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names used_th deps rdr_env fix_env src_warns + this_mod hsc_src used_names used_th deps rdr_env fix_env src_warns hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode ModDetails{ md_insts = insts, md_fam_insts = fam_insts, @@ -281,7 +281,7 @@ mkIface_ hsc_env maybe_old_fingerprint intermediate_iface = ModIface { mi_module = this_mod, mi_sig_of = sig_of, - mi_boot = is_boot, + mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, mi_exports = mkIfaceExports exports, @@ -1334,9 +1334,20 @@ checkDependencies hsc_env summary iface find_res <- liftIO $ findImportedModule hsc_env mod (fmap snd pkg) let reason = moduleNameString mod ++ " changed" case find_res of - Found _ mod + FoundModule h -> check_mod reason (fr_mod h) + FoundSigs hs _backing -> check_mods reason (map fr_mod hs) + _otherwise -> return (RecompBecause reason) + + check_mods _ [] = return UpToDate + check_mods reason (m:ms) = do + r <- check_mod reason m + case r of + UpToDate -> check_mods reason ms + _otherwise -> return r + + check_mod reason mod | pkg == this_pkg - -> if moduleName mod `notElem` map fst prev_dep_mods + = if moduleName mod `notElem` map fst prev_dep_mods then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " not among previous dependencies" @@ -1344,7 +1355,7 @@ checkDependencies hsc_env summary iface else return UpToDate | otherwise - -> if pkg `notElem` (map fst prev_dep_pkgs) + = if pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> @@ -1353,7 +1364,6 @@ checkDependencies hsc_env summary iface else return UpToDate where pkg = modulePackageKey mod - _otherwise -> return (RecompBecause reason) needInterface :: Module -> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 4f80fc9c4e..a7c340f780 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -165,13 +165,13 @@ typecheckIface iface ************************************************************************ -} -tcHiBootIface :: HscSource -> Module -> TcRn ModDetails +tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo -- Load the hi-boot iface for the module being compiled, -- if it indeed exists in the transitive closure of imports --- Return the ModDetails, empty if no hi-boot iface +-- Return the ModDetails; Nothing if no hi-boot iface tcHiBootIface hsc_src mod | HsBootFile <- hsc_src -- Already compiling a hs-boot file - = return emptyModDetails + = return NoSelfBoot | otherwise = do { traceIf (text "loadHiBootInterface" <+> ppr mod) @@ -188,10 +188,10 @@ tcHiBootIface hsc_src mod -- And that's fine, because if M's ModInfo is in the HPT, then -- it's been compiled once, and we don't need to check the boot iface then do { hpt <- getHpt - ; case lookupUFM hpt (moduleName mod) of + ; case lookupUFM hpt (moduleName mod) of Just info | mi_boot (hm_iface info) - -> return (hm_details info) - _ -> return emptyModDetails } + -> return (mkSelfBootInfo (hm_details info)) + _ -> return NoSelfBoot } else do -- OK, so we're in one-shot mode. @@ -203,8 +203,9 @@ tcHiBootIface hsc_src mod True -- Hi-boot file ; case read_result of { - Succeeded (iface, _path) -> typecheckIface iface ; - Failed err -> + Succeeded (iface, _path) -> do { tc_iface <- typecheckIface iface + ; return (mkSelfBootInfo tc_iface) } ; + Failed err -> -- There was no hi-boot file. But if there is circularity in -- the module graph, there really should have been one. @@ -215,7 +216,7 @@ tcHiBootIface hsc_src mod -- disappeared. do { eps <- getEps ; case lookupUFM (eps_is_boot eps) (moduleName mod) of - Nothing -> return emptyModDetails -- The typical case + Nothing -> return NoSelfBoot -- The typical case Just (_, False) -> failWithTc moduleLoop -- Someone below us imported us! @@ -234,6 +235,15 @@ tcHiBootIface hsc_src mod elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> quotes (ppr mod) <> colon) 4 err + +mkSelfBootInfo :: ModDetails -> SelfBootInfo +mkSelfBootInfo mds + = SelfBoot { sb_mds = mds + , sb_tcs = mkNameSet (map tyConName (typeEnvTyCons iface_env)) + , sb_ids = mkNameSet (map idName (typeEnvIds iface_env)) } + where + iface_env = md_types mds + {- ************************************************************************ * * @@ -726,7 +736,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo } where vectVarMapping name - = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name) + = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name) ; var <- forkM (ptext (sLit "vect var") <+> ppr name) $ tcIfaceExtId name ; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+> @@ -754,7 +764,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo tcIfaceExtId name vectTyConVectMapping vars name - = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name) + = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name) ; vectTyConMapping vars name vName } diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 15350bca7d..fb02120747 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -256,6 +256,38 @@ genCall t@(PrimTarget op) [] args `appOL` stmts4 `snocOL` call return (stmts, top1 ++ top2) +-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands +-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will +-- generate 'mul' on 128-bit operands. Then we only need some plumbing to +-- extract the two 64-bit values out of 128-bit result. +genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend the operands ('mul' instruction requires the operands + -- and the result to be of the same type). Note that we don't use 'castVars' + -- because it tries to do LM_Sext. + (lhsVar, stmts1, decls1) <- exprToVar lhs + (rhsVar, stmts2, decls2) <- exprToVar rhs + (lhsExt, stmt3) <- doExpr width2x $ Cast LM_Zext lhsVar width2x + (rhsExt, stmt4) <- doExpr width2x $ Cast LM_Zext rhsVar width2x + -- Do the actual multiplication (note that the result is also 2x width). + (retV, stmt5) <- doExpr width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt + -- Extract the lower bits of the result into retL. + (retL, stmt6) <- doExpr width $ Cast LM_Trunc retV width + -- Now we right-shift the higher bits by width. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + (retShifted, stmt7) <- doExpr width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit + -- And extract them into retH. + (retH, stmt8) <- doExpr width $ Cast LM_Trunc retShifted width + dstRegL <- getCmmReg (CmmLocal dstL) + dstRegH <- getCmmReg (CmmLocal dstH) + let storeL = Store retL dstRegL + storeH = Store retH dstRegH + stmts = stmts1 `appOL` stmts2 `appOL` + toOL [ stmt3 , stmt4, stmt5, stmt6, stmt7, stmt8, storeL, storeH ] + return (stmts, decls1 ++ decls2) + -- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from -- which we need to extract the actual values. genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] = @@ -621,6 +653,8 @@ cmmPrimOpFunctions mop = do MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported + -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the + -- appropriate case of genCall. MO_U_Mul2 {} -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 310007d000..c51feeb491 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -248,7 +248,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps -- we've done it once during downsweep r <- findImportedModule hsc_env imp pkg ; case r of - Found loc _ + FoundModule (FoundHs { fr_loc = loc }) -- Home package: just depend on the .hi or hi-boot file | isJust (ml_hs_file loc) || include_pkg_deps -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) @@ -257,6 +257,9 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps | otherwise -> return Nothing + -- TODO: FoundSignature. For now, we assume home package + -- "signature" dependencies look like FoundModule. + fail -> let dflags = hsc_dflags hsc_env in throwOneError $ mkPlainErrMsg dflags srcloc $ diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index 9d1199339a..ff6f8b8ab1 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -41,6 +41,7 @@ import {-# SOURCE #-} DynFlags import Outputable import Platform import System.FilePath +import Binary ----------------------------------------------------------------------------- -- Phases @@ -95,6 +96,17 @@ data HscSource deriving( Eq, Ord, Show ) -- Ord needed for the finite maps we build in CompManager +instance Binary HscSource where + put_ bh HsSrcFile = putByte bh 0 + put_ bh HsBootFile = putByte bh 1 + put_ bh HsigFile = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return HsSrcFile + 1 -> return HsBootFile + _ -> return HsigFile + hscSourceString :: HscSource -> String hscSourceString HsSrcFile = "" hscSourceString HsBootFile = "[boot]" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 3affcb1c73..97e64c4a37 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -186,7 +186,7 @@ compileOne' m_tc_result mHscMessage case e of Left iface -> do details <- genModDetails hsc_env iface - MASSERT(isJust maybe_old_linkable) + MASSERT(isJust maybe_old_linkable || isNoLink (ghcLink dflags)) return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) @@ -251,7 +251,18 @@ compileOne' m_tc_result mHscMessage do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash hscWriteIface dflags iface changed summary - compileEmptyStub dflags hsc_env basename location + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + let mod_name = ms_mod_name summary + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name HscUpdateSig)) + (Just basename) + Persistent + (Just location) + Nothing -- Same as Hs o_time <- getModificationUTCTime object_filename diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 183ea43707..74e9bf303d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -100,6 +100,10 @@ module DynFlags ( parseDynamicFilePragma, parseDynamicFlagsFull, + -- ** Package key cache + PackageKeyCache, + ShPackageKey(..), + -- ** Available DynFlags allFlags, flagsAll, @@ -177,6 +181,8 @@ import Foreign.C ( CInt(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) #endif import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) +import UniqFM +import UniqSet import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef @@ -331,6 +337,7 @@ data GeneralFlag | Opt_PrintExplicitForalls | Opt_PrintExplicitKinds | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms -- optimisation opts | Opt_CallArity @@ -441,6 +448,8 @@ data GeneralFlag | Opt_SuppressIdInfo -- Suppress separate type signatures in core, but leave types on -- lambda bound vars + | Opt_SuppressUnfoldings + -- Suppress the details of even stable unfoldings | Opt_SuppressTypeSignatures -- Suppress unique ids on variables. -- Except for uniques, as some simplifier phases introduce new @@ -651,6 +660,29 @@ type SigOf = Map ModuleName Module getSigOf :: DynFlags -> ModuleName -> Maybe Module getSigOf dflags n = Map.lookup n (sigOf dflags) +-- NameCache updNameCache +type PackageKeyEnv = UniqFM +type PackageKeyCache = PackageKeyEnv ShPackageKey + +-- | An elaborated representation of a 'PackageKey', which records +-- all of the components that go into the hashed 'PackageKey'. +data ShPackageKey + = ShPackageKey { + shPackageKeyUnitName :: !UnitName, + shPackageKeyLibraryName :: !LibraryName, + shPackageKeyInsts :: ![(ModuleName, Module)], + shPackageKeyFreeHoles :: UniqSet ModuleName + } + | ShDefinitePackageKey { + shPackageKey :: !PackageKey + } + deriving Eq + +instance Outputable ShPackageKey where + ppr (ShPackageKey pn vh insts fh) + = ppr pn <+> ppr vh <+> ppr insts <+> parens (ppr fh) + ppr (ShDefinitePackageKey pk) = ppr pk + -- | Contains not only a collection of 'GeneralFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags { @@ -695,7 +727,10 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - thisPackage :: PackageKey, -- ^ name of package currently being compiled + thisPackage :: PackageKey, -- ^ key of package currently being compiled + thisLibraryName :: LibraryName, + -- ^ the version hash which identifies the textual + -- package being compiled. -- ways ways :: [Way], -- ^ Way flags from the command line @@ -782,6 +817,7 @@ data DynFlags = DynFlags { -- Packages.initPackages pkgDatabase :: Maybe [PackageConfig], pkgState :: PackageState, + pkgKeyCache :: {-# UNPACK #-} !(IORef PackageKeyCache), -- Temporary files -- These have to be IORefs, because the defaultCleanupHandler needs to @@ -1434,6 +1470,7 @@ defaultDynFlags mySettings = solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, thisPackage = mainPackageKey, + thisLibraryName = LibraryName nilFS, objectDir = Nothing, dylibInstallName = Nothing, @@ -1479,6 +1516,7 @@ defaultDynFlags mySettings = pkgDatabase = Nothing, -- This gets filled in with GHC.setSessionDynFlags pkgState = emptyPackageState, + pkgKeyCache = v_unsafePkgKeyCache, ways = defaultWays mySettings, buildTag = mkBuildTag (defaultWays mySettings), rtsBuildTag = mkBuildTag (defaultWays mySettings), @@ -2727,6 +2765,7 @@ package_flags = [ upd (setPackageKey name) deprecate "Use -this-package-key instead") , defGhcFlag "this-package-key" (hasArg setPackageKey) + , defGhcFlag "library-name" (hasArg setLibraryName) , defFlag "package-id" (HasArg exposePackageId) , defFlag "package" (HasArg exposePackage) , defFlag "package-key" (HasArg exposePackageKey) @@ -2904,6 +2943,7 @@ dFlags = [ flagSpec "ppr-ticks" Opt_PprShowTicks, flagSpec "suppress-coercions" Opt_SuppressCoercions, flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, @@ -2968,6 +3008,7 @@ fFlags = [ flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, flagSpec "regs-graph" Opt_RegsGraph, @@ -3206,7 +3247,8 @@ defaultFlags settings ++ (if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) then wayGeneralFlags platform WayDyn - else []) + else [Opt_Static]) + -- Opt_Static needs to be set if and only if WayDyn is not used (#7478) where platform = sTargetPlatform settings @@ -3719,6 +3761,9 @@ exposePackage' p dflags setPackageKey :: String -> DynFlags -> DynFlags setPackageKey p s = s{ thisPackage = stringToPackageKey p } +setLibraryName :: String -> DynFlags -> DynFlags +setLibraryName v s = s{ thisLibraryName = LibraryName (mkFastString v) } + -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) -- @@ -4173,6 +4218,8 @@ unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags setUnsafeGlobalDynFlags :: DynFlags -> IO () setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags +GLOBAL_VAR(v_unsafePkgKeyCache, emptyUFM, PackageKeyCache) + -- ----------------------------------------------------------------------------- -- SSE and AVX diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 0d72bece36..3b62717a9c 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -203,7 +203,15 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do -- First find the package the module resides in by searching exposed packages and home modules found_module <- findImportedModule hsc_env mod_name Nothing case found_module of - Found _ mod -> do + FoundModule h -> check_mod (fr_mod h) + FoundSigs hs _backing -> check_mods (map fr_mod hs) -- (not tested) + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + meth = "lookupRdrNameInModule" + doc = ptext (sLit $ "contains a name used in an invocation of " ++ meth) + + check_mod mod = do -- Find the exports of the module (_, mb_iface) <- initTcInteractive hsc_env $ initIfaceTcRn $ @@ -221,10 +229,13 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env - doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule") + + check_mods [] = return Nothing + check_mods (m:ms) = do + r <- check_mod m + case r of + Nothing -> check_mods ms + Just _ -> return r wrongTyThingError :: Name -> TyThing -> SDoc wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 00ba0388dd..d8aef57011 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -9,6 +9,7 @@ module Finder ( flushFinderCaches, FindResult(..), + convFindExactResult, -- move to HscTypes? findImportedModule, findExactModule, findHomeModule, @@ -45,8 +46,7 @@ import System.Directory import System.FilePath import Control.Monad import Data.Time -import Data.List ( foldl' ) - +import Data.List ( foldl', partition ) type FileExt = String -- Filename extension type BaseName = String -- Basename of file @@ -75,7 +75,7 @@ flushFinderCaches hsc_env = is_ext mod _ | modulePackageKey mod /= this_pkg = True | otherwise = False -addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO () +addToFinderCache :: IORef FinderCache -> Module -> FindExactResult -> IO () addToFinderCache ref key val = atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ()) @@ -83,7 +83,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO () removeFromFinderCache ref key = atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult) +lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindExactResult) lookupFinderCache ref key = do c <- readIORef ref return $! lookupModuleEnv c key @@ -104,7 +104,7 @@ findImportedModule hsc_env mod_name mb_pkg = Just pkg | pkg == fsLit "this" -> home_import -- "this" is special | otherwise -> pkg_import where - home_import = findHomeModule hsc_env mod_name + home_import = convFindExactResult `fmap` findHomeModule hsc_env mod_name pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg @@ -118,7 +118,7 @@ findImportedModule hsc_env mod_name mb_pkg = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> Module -> IO FindResult +findExactModule :: HscEnv -> Module -> IO FindExactResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env in if modulePackageKey mod == thisPackage dflags @@ -152,17 +152,45 @@ orIfNotFound this or_this = do -- been done. Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.) -homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult +homeSearchCache :: HscEnv + -> ModuleName + -> IO FindExactResult + -> IO FindExactResult homeSearchCache hsc_env mod_name do_this = do let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name modLocationCache hsc_env mod do_this +-- | Converts a 'FindExactResult' into a 'FindResult' in the obvious way. +convFindExactResult :: FindExactResult -> FindResult +convFindExactResult (FoundExact loc m) = FoundModule (FoundHs loc m) +convFindExactResult (NoPackageExact pk) = NoPackage pk +convFindExactResult NotFoundExact { fer_paths = paths, fer_pkg = pkg } = + NotFound { + fr_paths = paths, fr_pkg = pkg, + fr_pkgs_hidden = [], fr_mods_hidden = [], fr_suggestions = [] + } + +foundExact :: FindExactResult -> Bool +foundExact FoundExact{} = True +foundExact _ = False + findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findExposedPackageModule hsc_env mod_name mb_pkg = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of - LookupFound m pkg_conf -> - findPackageModule_ hsc_env m pkg_conf + LookupFound (m, _) -> do + fmap convFindExactResult (findPackageModule hsc_env m) + LookupFoundSigs ms backing -> do + locs <- mapM (findPackageModule hsc_env . fst) ms + let (ok, missing) = partition foundExact locs + case missing of + -- At the moment, we return the errors one at a time. It might be + -- better if we collected them up and reported them all, but + -- FindResult doesn't have enough information to support this. + -- In any case, this REALLY shouldn't happen (it means there are + -- broken packages in the database.) + (m:_) -> return (convFindExactResult m) + _ -> return (FoundSigs [FoundHs l m | FoundExact l m <- ok] backing) LookupMultiple rs -> return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> @@ -176,7 +204,7 @@ findExposedPackageModule hsc_env mod_name mb_pkg , fr_mods_hidden = [] , fr_suggestions = suggest }) -modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult +modLocationCache :: HscEnv -> Module -> IO FindExactResult -> IO FindExactResult modLocationCache hsc_env mod do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod case m of @@ -189,7 +217,7 @@ modLocationCache hsc_env mod do_this = do addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder hsc_env mod_name loc = do let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name - addToFinderCache (hsc_FC hsc_env) mod (Found loc mod) + addToFinderCache (hsc_FC hsc_env) mod (FoundExact loc mod) return mod uncacheModule :: HscEnv -> ModuleName -> IO () @@ -216,7 +244,7 @@ uncacheModule hsc_env mod = do -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to -- call this.) -findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule :: HscEnv -> ModuleName -> IO FindExactResult findHomeModule hsc_env mod_name = homeSearchCache hsc_env mod_name $ let @@ -247,19 +275,19 @@ findHomeModule hsc_env mod_name = -- This is important only when compiling the base package (where GHC.Prim -- is a home module). if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) + then return (FoundExact (error "GHC.Prim ModLocation") mod) else searchPathExts home_path mod exts -- | Search for a module in external packages only. -findPackageModule :: HscEnv -> Module -> IO FindResult +findPackageModule :: HscEnv -> Module -> IO FindExactResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env pkg_id = modulePackageKey mod -- case lookupPackage dflags pkg_id of - Nothing -> return (NoPackage pkg_id) + Nothing -> return (NoPackageExact pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf -- | Look up the interface file associated with module @mod@. This function @@ -269,14 +297,14 @@ findPackageModule hsc_env mod = do -- the 'PackageConfig' must be consistent with the package key in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult +findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindExactResult findPackageModule_ hsc_env mod pkg_conf = ASSERT( modulePackageKey mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) + then return (FoundExact (error "GHC.Prim ModLocation") mod) else let @@ -299,7 +327,7 @@ findPackageModule_ hsc_env mod pkg_conf = -- don't bother looking for it. let basename = moduleNameSlashes (moduleName mod) loc <- mk_hi_loc one basename - return (Found loc mod) + return (FoundExact loc mod) _otherwise -> searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] @@ -314,7 +342,7 @@ searchPathExts FilePath -> BaseName -> IO ModLocation -- action ) ] - -> IO FindResult + -> IO FindExactResult searchPathExts paths mod exts = do result <- search to_search @@ -340,15 +368,13 @@ searchPathExts paths mod exts file = base <.> ext ] - search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (modulePackageKey mod) - , fr_mods_hidden = [], fr_pkgs_hidden = [] - , fr_suggestions = [] }) + search [] = return (NotFoundExact {fer_paths = map fst to_search + ,fer_pkg = Just (modulePackageKey mod)}) search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then do { loc <- mk_result; return (Found loc mod) } + then do { loc <- mk_result; return (FoundExact loc mod) } else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt @@ -571,7 +597,8 @@ cantFindErr cannot_find _ dflags mod_name find_result vcat (map mod_hidden mod_hiddens) $$ tried_these files - _ -> panic "cantFindErr" + _ -> pprPanic "cantFindErr" + (ptext cannot_find <+> quotes (ppr mod_name)) build_tag = buildTag dflags diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 1a7d4ef71e..d9380e10c3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1378,6 +1378,20 @@ showRichTokenStream ts = go startLoc ts "" -- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. +-- +-- However, there is a twist for local modules, see #2682. +-- +-- The full algorithm: +-- IF it's a package qualified import for a REMOTE package (not @this_pkg@ or +-- this), do a normal lookup. +-- OTHERWISE see if it is ALREADY loaded, and use it if it is. +-- OTHERWISE do a normal lookup, but reject the result if the found result +-- is from the LOCAL package (@this_pkg@). +-- +-- For signatures, we return the BACKING implementation to keep the API +-- consistent with what we had before. (ToDo: create a new GHC API which +-- can deal with signatures.) +-- findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do let @@ -1388,17 +1402,23 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found _ m -> return m + FoundModule h -> return (fr_mod h) + FoundSigs _ backing -> return backing err -> throwOneError $ noModError dflags noSrcSpan mod_name err _otherwise -> do home <- lookupLoadedHomeModule mod_name case home of + -- TODO: This COULD be a signature Just m -> return m Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | modulePackageKey m /= this_pkg -> return m - | otherwise -> modNotLoadedError dflags m loc + FoundModule (FoundHs { fr_mod = m, fr_loc = loc }) + | modulePackageKey m /= this_pkg -> return m + | otherwise -> modNotLoadedError dflags m loc + FoundSigs (FoundHs { fr_loc = loc, fr_mod = m }:_) backing + | modulePackageKey m /= this_pkg -> return backing + | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a @@ -1419,11 +1439,13 @@ lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) lookupModule mod_name Nothing = withSession $ \hsc_env -> do home <- lookupLoadedHomeModule mod_name case home of + -- TODO: This COULD be a signature Just m -> return m Nothing -> liftIO $ do res <- findExposedPackageModule hsc_env mod_name Nothing case res of - Found _ m -> return m + FoundModule (FoundHs { fr_mod = m }) -> return m + FoundSigs _ backing -> return backing err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 2d1d9ebf52..89cab9ef3a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1815,7 +1815,10 @@ findSummaryBySourceFile summaries file [] -> Nothing (x:_) -> Just x --- Summarise a module, and pick up source and timestamp. +-- | Summarise a module, and pick up source and timestamp. +-- Returns @Nothing@ if the module is excluded via @excl_mods@ or is an +-- external package module (which we don't compile), otherwise returns the +-- new module summary (or an error saying why we couldn't summarise it). summariseModule :: HscEnv -> NodeMap ModSummary -- Map of old summaries @@ -1877,7 +1880,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) uncacheModule hsc_env wanted_mod found <- findImportedModule hsc_env wanted_mod Nothing case found of - Found location mod + -- TODO: When we add -alias support, we can validly find + -- multiple signatures in the home package; need to make this + -- logic more flexible in that case. + FoundModule (FoundHs { fr_loc = location, fr_mod = mod }) | isJust (ml_hs_file location) -> -- Home package just_found location mod @@ -1886,6 +1892,15 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ASSERT(modulePackageKey mod /= thisPackage dflags) return Nothing + FoundSigs hs _backing + | Just (FoundHs { fr_loc = location, fr_mod = mod }) + <- find (isJust . ml_hs_file . fr_loc) hs -> + just_found location mod + | otherwise -> + ASSERT(all (\h -> modulePackageKey (fr_mod h) + /= thisPackage dflags) hs) + return Nothing + err -> return $ Just $ Left $ noModError dflags loc wanted_mod err -- Not found diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 94896b0e86..328655c6d0 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1520,9 +1520,29 @@ hscDeclsWithLocation hsc_env0 str source linenumber = new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns ictxt = hsc_IC hsc_env - new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts fam_insts defaults + -- See Note [Fixity declarations in GHCi] + fix_env = tcg_fix_env tc_gblenv + new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts + fam_insts defaults fix_env return (new_tythings, new_ictxt) + +{- + Note [Fixity declarations in GHCi] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + To support fixity declarations on types defined within GHCi (as requested + in #10018) we record the fixity environment in InteractiveContext. + When we want to evaluate something TcRnDriver.runTcInteractive pulls out this + fixity environment and uses it to initialize the global typechecker environment. + After the typechecker has finished its business, an updated fixity environment + (reflecting whatever fixity declarations were present in the statements we + passed it) will be returned from hscParsedStmt. This is passed to + updateFixityEnv, which will stuff it back into InteractiveContext, to be + used in evaluating the next statement. + +-} + hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- @@ -1622,7 +1642,7 @@ mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts mkModGuts mod safe binds = ModGuts { mg_module = mod, - mg_boot = False, + mg_hsc_src = HsSrcFile, mg_exports = [], mg_deps = noDependencies, mg_dir_imps = emptyModuleEnv, diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index b7707f80af..7bceda50f6 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -10,7 +10,7 @@ module HscTypes ( -- * compilation state HscEnv(..), hscEPS, - FinderCache, FindResult(..), + FinderCache, FindResult(..), FoundHs(..), FindExactResult(..), Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, HscStatus(..), @@ -67,7 +67,7 @@ module HscTypes ( -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, - emptyIfaceWarnCache, + emptyIfaceWarnCache, mi_boot, -- * Fixity FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, @@ -674,15 +674,30 @@ prepareAnnotations hsc_env mb_guts = do -- modules along the search path. On @:load@, we flush the entire -- contents of this cache. -- --- Although the @FinderCache@ range is 'FindResult' for convenience, --- in fact it will only ever contain 'Found' or 'NotFound' entries. --- -type FinderCache = ModuleEnv FindResult +type FinderCache = ModuleEnv FindExactResult + +-- | The result of search for an exact 'Module'. +data FindExactResult + = FoundExact ModLocation Module + -- ^ The module/signature was found + | NoPackageExact PackageKey + | NotFoundExact + { fer_paths :: [FilePath] + , fer_pkg :: Maybe PackageKey + } + +-- | A found module or signature; e.g. anything with an interface file +data FoundHs = FoundHs { fr_loc :: ModLocation + , fr_mod :: Module + -- , fr_origin :: ModuleOrigin + } -- | The result of searching for an imported module. data FindResult - = Found ModLocation Module + = FoundModule FoundHs -- ^ The module was found + | FoundSigs [FoundHs] Module + -- ^ Signatures were found, with some backing implementation | NoPackage PackageKey -- ^ The requested package was not found | FoundMultiple [(Module, ModuleOrigin)] @@ -733,7 +748,7 @@ data ModIface mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans mi_finsts :: !WhetherHasFamInst, -- ^ Whether this module has family instances - mi_boot :: !IsBootInterface, -- ^ Read from an hi-boot file? + mi_hsc_src :: !HscSource, -- ^ Boot? Signature? mi_deps :: Dependencies, -- ^ The dependencies of the module. This is @@ -831,11 +846,16 @@ data ModIface -- See Note [RnNames . Trust Own Package] } +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> Bool +mi_boot iface = mi_hsc_src iface == HsBootFile + instance Binary ModIface where put_ bh (ModIface { mi_module = mod, mi_sig_of = sig_of, - mi_boot = is_boot, + mi_hsc_src = hsc_src, mi_iface_hash= iface_hash, mi_mod_hash = mod_hash, mi_flag_hash = flag_hash, @@ -859,7 +879,7 @@ instance Binary ModIface where mi_trust = trust, mi_trust_pkg = trust_pkg }) = do put_ bh mod - put_ bh is_boot + put_ bh hsc_src put_ bh iface_hash put_ bh mod_hash put_ bh flag_hash @@ -886,7 +906,7 @@ instance Binary ModIface where get bh = do mod_name <- get bh - is_boot <- get bh + hsc_src <- get bh iface_hash <- get bh mod_hash <- get bh flag_hash <- get bh @@ -913,7 +933,7 @@ instance Binary ModIface where return (ModIface { mi_module = mod_name, mi_sig_of = sig_of, - mi_boot = is_boot, + mi_hsc_src = hsc_src, mi_iface_hash = iface_hash, mi_mod_hash = mod_hash, mi_flag_hash = flag_hash, @@ -955,7 +975,7 @@ emptyModIface mod mi_flag_hash = fingerprint0, mi_orphan = False, mi_finsts = False, - mi_boot = False, + mi_hsc_src = HsSrcFile, mi_deps = noDependencies, mi_usages = [], mi_exports = [], @@ -1033,7 +1053,7 @@ type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled - mg_boot :: IsBootInterface, -- ^ Whether it's an hs-boot module + mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module mg_exports :: ![AvailInfo], -- ^ What it exports mg_deps :: !Dependencies, -- ^ What it depends on, directly or -- otherwise @@ -1065,23 +1085,24 @@ data ModGuts -- (produced by desugarer & consumed by vectoriser) mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module - -- The next two fields are unusual, because they give instance - -- environments for *all* modules in the home package, including - -- this module, rather than for *just* this module. - -- Reason: when looking up an instance we don't want to have to - -- look at each module in the home package in turn - mg_inst_env :: InstEnv, - -- ^ Class instance environment from /home-package/ modules (including - -- this one); c.f. 'tcg_inst_env' - mg_fam_inst_env :: FamInstEnv, - -- ^ Type-family instance environment for /home-package/ modules - -- (including this one); c.f. 'tcg_fam_inst_env' - mg_safe_haskell :: SafeHaskellMode, - -- ^ Safe Haskell mode - mg_trust_pkg :: Bool, - -- ^ Do we need to trust our own package for Safe Haskell? - -- See Note [RnNames . Trust Own Package] - mg_dependent_files :: [FilePath] -- ^ dependencies from addDependentFile + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, -- ^ Class instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_fam_inst_env' + + mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode + mg_trust_pkg :: Bool, -- ^ Do we need to trust our + -- own package for Safe Haskell? + -- See Note [RnNames . Trust Own Package] + + mg_dependent_files :: [FilePath] -- ^ Dependencies from addDependentFile } -- The ModGuts takes on several slightly different forms: @@ -1090,7 +1111,6 @@ data ModGuts -- mg_rules Orphan rules only (local ones now attached to binds) -- mg_binds With rules attached - --------------------------------------------------------- -- The Tidy pass forks the information about this module: -- * one lot goes to interface file generation (ModIface) @@ -1405,8 +1425,9 @@ extendInteractiveContext :: InteractiveContext -> [TyThing] -> [ClsInst] -> [FamInst] -> Maybe [Type] + -> FixityEnv -> InteractiveContext -extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults +extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env = ictxt { ic_mod_index = ic_mod_index ictxt + 1 -- Always bump this; even instances should create -- a new mod_index (Trac #9426) @@ -1414,7 +1435,9 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings , ic_instances = ( new_cls_insts ++ old_cls_insts , new_fam_insts ++ old_fam_insts ) - , ic_default = defaults } + , ic_default = defaults + , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] + } where new_ids = [id | AnId id <- new_tythings] old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) @@ -2069,6 +2092,15 @@ type IsBootInterface = Bool -- Invariant: the dependencies of a module @M@ never includes @M@. -- -- Invariant: none of the lists contain duplicates. +-- +-- NB: While this contains information about all modules and packages below +-- this one in the the import *hierarchy*, this may not accurately reflect +-- the full runtime dependencies of the module. This is because this module may +-- have imported a boot module, in which case we'll only have recorded the +-- dependencies from the hs-boot file, not the actual hs file. (This is +-- unavoidable: usually, the actual hs file will have been compiled *after* +-- we wrote this interface file.) See #936, and also @getLinkDeps@ in +-- @compiler/ghci/Linker.hs@ for code which cares about this distinction. data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ All home-package modules transitively below this one diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 3c41151c11..71a84d8622 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -12,13 +12,18 @@ module PackageConfig ( -- * PackageKey packageConfigId, + -- * LibraryName + LibraryName(..), + -- * The PackageConfig type: information about a package PackageConfig, InstalledPackageInfo(..), InstalledPackageId(..), SourcePackageId(..), PackageName(..), + UnitName(..), Version(..), + packageUnitName, defaultPackageConfig, installedPackageIdString, sourcePackageIdString, @@ -54,6 +59,8 @@ type PackageConfig = InstalledPackageInfo newtype InstalledPackageId = InstalledPackageId FastString deriving (Eq, Ord) newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) newtype PackageName = PackageName FastString deriving (Eq, Ord) +newtype UnitName = UnitName FastString deriving (Eq, Ord) +newtype LibraryName = LibraryName FastString deriving (Eq, Ord) instance BinaryStringRep InstalledPackageId where fromStringRep = InstalledPackageId . mkFastStringByteString @@ -67,6 +74,10 @@ instance BinaryStringRep PackageName where fromStringRep = PackageName . mkFastStringByteString toStringRep (PackageName s) = fastStringToByteString s +instance BinaryStringRep LibraryName where + fromStringRep = LibraryName . mkFastStringByteString + toStringRep (LibraryName s) = fastStringToByteString s + instance Uniquable InstalledPackageId where getUnique (InstalledPackageId n) = getUnique n @@ -79,6 +90,12 @@ instance Uniquable PackageName where instance Outputable InstalledPackageId where ppr (InstalledPackageId str) = ftext str +instance Outputable UnitName where + ppr (UnitName str) = ftext str + +instance Outputable LibraryName where + ppr (LibraryName str) = ftext str + instance Outputable SourcePackageId where ppr (SourcePackageId str) = ftext str @@ -172,3 +189,6 @@ pprPackageConfig InstalledPackageInfo {..} = packageConfigId :: PackageConfig -> PackageKey packageConfigId = packageKey +packageUnitName :: PackageConfig -> UnitName +packageUnitName pkg = let PackageName fs = packageName pkg + in UnitName fs diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 0be5e3ffaf..20822476cd 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -132,9 +132,10 @@ import qualified Data.Set as Set -- in a different DLL, by setting the DLL flag. -- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! +-- possibly simultaneously. For a given particular implementation (e.g. +-- original module, or even a signature module), this data type tracks all the +-- possible ways it could have come into scope. Warning: don't use the record +-- functions, they're partial! data ModuleOrigin = -- | Module is hidden, and thus never will be available for import. -- (But maybe the user didn't realize), so we'll still keep track @@ -158,7 +159,7 @@ data ModuleOrigin = } instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" + ppr ModHidden = text "hidden module" -- NB: cannot be signature ppr (ModOrigin e res rhs f) = sep (punctuate comma ( (case e of Nothing -> [] @@ -175,17 +176,18 @@ instance Outputable ModuleOrigin where (if f then [text "package flag"] else []) )) --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False +-- | Smart constructor for a module which is in @exposed-modules@ or +-- @exposed-signatures@. Takes as an argument whether or not the defining +-- package is exposed. +fromExposed :: Bool -> ModuleOrigin +fromExposed e = ModOrigin (Just e) [] [] False --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is expsed, and --- also its 'PackageConfig'. -fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False +-- | Smart constructor for a module which is in @reexported-modules@ +-- or @reexported-signatures@. Takes as an argument whether or not the +-- reexporting package is expsed, and also its 'PackageConfig'. +fromReexported :: Bool -> PackageConfig -> ModuleOrigin +fromReexported True pkg = ModOrigin Nothing [pkg] [] False +fromReexported False pkg = ModOrigin Nothing [] [pkg] False -- | Smart constructor for a module which was bound by a package flag. fromFlag :: ModuleOrigin @@ -227,11 +229,40 @@ type PackageConfigMap = PackageKeyMap PackageConfig type VisibilityMap = PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) --- | Map from 'ModuleName' to 'Module' to all the origins of the bindings --- in scope. The 'PackageConf' is not cached, mostly for convenience reasons --- (since this is the slow path, we'll just look it up again). -type ModuleToPkgConfAll = - Map ModuleName (Map Module ModuleOrigin) +-- | Alias for 'Module' indicating we expect the interface in question to +-- be for a signature. +type Signature = Module + +-- | Alias for 'ModuleOrigin' indicating we expect it to describe a signature. +type SignatureOrigin = ModuleOrigin + +-- | This is the main lookup structure we use to handle imports, which map +-- from 'ModuleName' to 'ModuleDb', which describes all possible implementations +-- which are available under a module name. +type ModuleNameDb = Map ModuleName ModuleDb + +-- | This is an auxiliary structure per module name, and it's a map of +-- backing implementations to more information about them. This is a map +-- so it's easy to tell if we're bringing in an implementation for a name +-- which is already in scope (and thus non-conflicting.) +type ModuleDb = Map Module ModuleDesc + +-- | Per backing implementation, there may be multiple signatures available +-- exporting subsets of its interface; we need to track all of them. +type SignatureDb = Map Signature SignatureOrigin + +-- | Combined module description for a module: includes 'ModuleOrigin' +-- describing the backing implementation, as well as 'SignatureDb' for any +-- signatures of the module in question. +data ModuleDesc = MD ModuleOrigin SignatureDb + +instance Outputable ModuleDesc where + ppr (MD o m) = ppr o <+> parens (ppr m) + +instance Monoid ModuleDesc where + mempty = MD mempty Map.empty + mappend (MD o m) (MD o' m') = MD (o `mappend` o') + (Map.unionWith mappend m m') data PackageState = PackageState { -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted @@ -249,7 +280,7 @@ data PackageState = PackageState { -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import. - moduleToPkgConfAll :: ModuleToPkgConfAll, + moduleNameDb :: ModuleNameDb, -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC -- internally deals in package keys but the database may refer to installed @@ -261,7 +292,7 @@ emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyUFM, preloadPackages = [], - moduleToPkgConfAll = Map.empty, + moduleNameDb = Map.empty, installedPackageIdMap = Map.empty } @@ -332,7 +363,7 @@ initPackages dflags = do Nothing -> readPackageConfigs dflags Just db -> return $ setBatchPackageFlags dflags db (pkg_state, preload, this_pkg) - <- mkPackageState dflags pkg_db [] (thisPackage dflags) + <- mkPackageState dflags pkg_db [] return (dflags{ pkgDatabase = Just pkg_db, pkgState = pkg_state, thisPackage = this_pkg }, @@ -854,15 +885,17 @@ mkPackageState :: DynFlags -> [PackageConfig] -- initial database -> [PackageKey] -- preloaded packages - -> PackageKey -- this package -> IO (PackageState, [PackageKey], -- new packages to preload PackageKey) -- this package, might be modified if the current -- package is a wired-in package. -mkPackageState dflags0 pkgs0 preload0 this_package = do +mkPackageState dflags0 pkgs0 preload0 = do dflags <- interpretPackageEnv dflags0 + -- Compute the package key + let this_package = thisPackage dflags + {- Plan. @@ -1025,7 +1058,7 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, + moduleNameDb = mkModuleNameDb dflags pkg_db ipid_map vis_map, installedPackageIdMap = ipid_map } return (pstate, new_dep_preload, this_package) @@ -1034,62 +1067,70 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info -mkModuleToPkgConfAll +mkModuleNameDb :: DynFlags -> PackageConfigMap -> InstalledPackageIdMap -> VisibilityMap - -> ModuleToPkgConfAll -mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map = + -> ModuleNameDb +mkModuleNameDb dflags pkg_db ipid_map vis_map = foldl' extend_modmap emptyMap (eltsUFM pkg_db) where emptyMap = Map.empty - sing pk m _ = Map.singleton (mkModule pk m) + sing pk m = Map.singleton (mkModule pk m) addListTo = foldl' merge merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m - setOrigins m os = fmap (const os) m extend_modmap modmap pkg = addListTo modmap theBindings where - theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings :: [(ModuleName, ModuleDb)] theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) = newBindings b rns | otherwise = newBindings False [] newBindings :: Bool -> [(ModuleName, ModuleName)] - -> [(ModuleName, Map Module ModuleOrigin)] + -> [(ModuleName, ModuleDb)] newBindings e rns = es e ++ hiddens ++ map rnBinding rns rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, Map Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + -> (ModuleName, ModuleDb) + rnBinding (orig, new) = (new, fmap applyFlag origEntry) where origEntry = case lookupUFM esmap orig of Just r -> r Nothing -> throwGhcException (CmdLineError (showSDoc dflags (text "package flag: could not find module name" <+> ppr orig <+> text "in package" <+> ppr pk))) - es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + applyFlag (MD _ sigs) = MD fromFlag (fmap (const fromFlag) sigs) + + es :: Bool -> [(ModuleName, ModuleDb)] es e = do - -- TODO: signature support - ExposedModule m exposedReexport _exposedSignature <- exposed_mods - let (pk', m', pkg', origin') = + ExposedModule m exposedReexport exposedSignature <- exposed_mods + let (pk', m', origin') = case exposedReexport of - Nothing -> (pk, m, pkg, fromExposedModules e) + Nothing -> (pk, m, fromExposed e) Just (OriginalModule ipid' m') -> - let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) - pkg' = pkg_lookup pk' - in (pk', m', pkg', fromReexportedModules e pkg') - return (m, sing pk' m' pkg' origin') + let (pk', pkg') = ipid_lookup ipid' + in (pk', m', fromReexported e pkg') + return $ case exposedSignature of + Nothing -> (m, sing pk' m' (MD origin' Map.empty)) + Just (OriginalModule ipid'' m'') -> + let (pk'', _) = ipid_lookup ipid'' + in (m, sing pk'' m'' (MD mempty (sing pk' m' origin'))) - esmap :: UniqFM (Map Module ModuleOrigin) + + esmap :: UniqFM ModuleDb esmap = listToUFM (es False) -- parameter here doesn't matter, orig will -- be overwritten - hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + hiddens :: [(ModuleName, ModuleDb)] + hiddens = [(m, sing pk m (MD ModHidden Map.empty)) | m <- hidden_mods] pk = packageConfigId pkg - pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + pkg_lookup = expectJust "mkModuleNameDb" . lookupPackage' pkg_db + ipid_lookup ipid = + let pk = expectJust "mkModuleNameDb" (Map.lookup ipid ipid_map) + in (pk, pkg_lookup pk) exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg @@ -1199,16 +1240,20 @@ lookupModuleInAllPackages :: DynFlags -> [(Module, PackageConfig)] lookupModuleInAllPackages dflags m = case lookupModuleWithSuggestions dflags m Nothing of - LookupFound a b -> [(a,b)] - LookupMultiple rs -> map f rs - where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags - (modulePackageKey m))) + LookupFound (m,_) -> [(m,get_pkg m)] + LookupMultiple rs -> map (\(m,_) -> (m,get_pkg m)) rs _ -> [] + where get_pkg = expectJust "lookupModule" . lookupPackage dflags + . modulePackageKey -- | The result of performing a lookup data LookupResult = -- | Found the module uniquely, nothing else to do - LookupFound Module PackageConfig + LookupFound (Module, ModuleOrigin) + -- | We found (possibly multiple) signatures with a unique backing + -- implementation: they should be "merged" together. For good measure, + -- the backing implementation is recorded too. + | LookupFoundSigs [(Module, ModuleOrigin)] Module -- | Multiple modules with the same name in scope | LookupMultiple [(Module, ModuleOrigin)] -- | No modules found, but there were some hidden ones with @@ -1218,6 +1263,39 @@ data LookupResult = -- | Nothing found, here are some suggested different names | LookupNotFound [ModuleSuggestion] -- suggestions +instance Monoid LookupResult where + mempty = LookupNotFound [] + + LookupNotFound s1 `mappend` LookupNotFound s2 + = LookupNotFound (s1 ++ s2) + LookupNotFound{} `mappend` l = l + l `mappend` LookupNotFound{} = l + + LookupHidden x1 y1 `mappend` LookupHidden x2 y2 + = LookupHidden (x1 ++ x2) (y1 ++ y2) + LookupHidden{} `mappend` l = l + l `mappend` LookupHidden{} = l + + LookupFound m1 `mappend` LookupFound m2 + = ASSERT(fst m1 /= fst m2) LookupMultiple [m1, m2] + LookupFound m `mappend` LookupMultiple ms + = ASSERT(not (any ((==fst m).fst) ms)) LookupMultiple (m:ms) + LookupFound m `mappend` LookupFoundSigs ms check + | fst m == check = LookupFound m + | otherwise = LookupMultiple (m:ms) + l1 `mappend` l2@LookupFound{} + = l2 `mappend` l1 + + LookupMultiple ms1 `mappend` LookupFoundSigs ms2 _ + = LookupMultiple (ms1 ++ ms2) + LookupMultiple ms1 `mappend` LookupMultiple ms2 + = LookupMultiple (ms1 ++ ms2) + l1 `mappend` l2@LookupMultiple{} + = l2 `mappend` l1 + + LookupFoundSigs ms1 m1 `mappend` LookupFoundSigs ms2 m2 + = ASSERT(m1 /= m2) LookupMultiple (ms1 ++ ms2) + data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin | SuggestHidden ModuleName Module ModuleOrigin @@ -1226,23 +1304,28 @@ lookupModuleWithSuggestions :: DynFlags -> Maybe FastString -> LookupResult lookupModuleWithSuggestions dflags m mb_pn - = case Map.lookup m (moduleToPkgConfAll pkg_state) of + = case Map.lookup m (moduleNameDb pkg_state) of Nothing -> LookupNotFound suggestions - Just xs -> - case foldl' classify ([],[],[]) (Map.toList xs) of - ([], [], []) -> LookupNotFound suggestions - (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) - (_, _, exposed@(_:_)) -> LookupMultiple exposed - (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod + Just xs -> mconcat (LookupNotFound suggestions + :map classify (Map.toList xs)) where - classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + classify (m, MD origin0 sigs0) = let origin = filterOrigin mb_pn (mod_pkg m) origin0 - x = (m, origin) + r = (m, origin) in case origin of - ModHidden -> (hidden_pkg, x:hidden_mod, exposed) - _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) - | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) - | otherwise -> (x:hidden_pkg, hidden_mod, exposed) + ModHidden -> LookupHidden [] [r] + _ | originVisible origin -> LookupFound r + | otherwise -> + let sigs = do (back_m, back_origin0) <- Map.toList sigs0 + let back_origin = filterOrigin mb_pn + (mod_pkg back_m) + back_origin0 + guard (originVisible back_origin) + return (back_m, back_origin) + in case sigs of + [] | originEmpty origin -> LookupNotFound [] + | otherwise -> LookupHidden [r] [] + _ -> LookupFoundSigs sigs m pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags pkg_state = pkgState dflags @@ -1277,17 +1360,18 @@ lookupModuleWithSuggestions dflags m mb_pn all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) - | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + | (m, e) <- Map.toList (moduleNameDb (pkgState dflags)) , suggestion <- map (getSuggestion m) (Map.toList e) ] - getSuggestion name (mod, origin) = + -- For now, don't suggest implemented signatures + getSuggestion name (mod, MD origin _) = (if originVisible origin then SuggestVisible else SuggestHidden) name mod origin listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames dflags = - map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) - where visible (_, ms) = any originVisible (Map.elems ms) + map fst (filter visible (Map.toList (moduleNameDb (pkgState dflags)))) + where visible (_, ms) = any (\(MD o _) -> originVisible o) (Map.elems ms) -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's @@ -1426,7 +1510,7 @@ pprPackagesSimple = pprPackagesWith pprIPI -- | Show the mapping of modules to where they come from. pprModuleMap :: DynFlags -> SDoc pprModuleMap dflags = - vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + vcat (map pprLine (Map.toList (moduleNameDb (pkgState dflags)))) where pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) pprEntry m (m',o) diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 91aaaee6aa..66eb0ef5e8 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -20,7 +20,8 @@ import CoreFVs import CoreTidy import CoreMonad import CorePrep -import CoreUtils +import CoreUtils (rhsIsStatic) +import CoreStats (coreBindsStats, CoreStats(..)) import CoreLint import Literal import Rules diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index a9293da401..7dce81c561 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1012,7 +1012,7 @@ withLexedDocType lexDocComment = do case prevChar buf ' ' of '|' -> lexDocComment input ITdocCommentNext False '^' -> lexDocComment input ITdocCommentPrev False - '$' -> lexDocComment input ITdocCommentNamed False + '$' -> lexDocComment input ITdocCommentNamed True '*' -> lexDocSection 1 input '#' -> lexDocComment input ITdocOptionsOld False _ -> panic "withLexedDocType: Bad doc type" diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index d6972532d7..99abf162d1 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1870,10 +1870,10 @@ gadt_constrlist :: { Located ([AddAnn] | {- empty -} { noLoc ([],[]) } gadt_constrs :: { Located [LConDecl RdrName] } - : gadt_constr ';' gadt_constrs + : gadt_constr_with_doc ';' gadt_constrs {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr { L (gl $1) [$1] } + | gadt_constr_with_doc { L (gl $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -1882,11 +1882,18 @@ gadt_constrs :: { Located [LConDecl RdrName] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a +gadt_constr_with_doc :: { LConDecl RdrName } +gadt_constr_with_doc + : maybe_docnext ';' gadt_constr + {% return $ addConDoc $3 $1 } + | gadt_constr + {% return $1 } + gadt_constr :: { LConDecl RdrName } -- Returns a list because of: C,D :: ty : con_list '::' sigtype {% do { (anns,gadtDecl) <- mkGadtDecl (unLoc $1) $3 - ; ams (sLL $1 $> $ gadtDecl) + ; ams (sLL $1 $> gadtDecl) (mj AnnDcolon $2:anns) } } -- Deprecated syntax for GADT record declarations diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs index 657660a735..bec849f728 100644 --- a/compiler/prelude/ForeignCall.hs +++ b/compiler/prelude/ForeignCall.hs @@ -239,7 +239,7 @@ instance Outputable Header where data CType = CType SourceText -- Note [Pragma source text] in BasicTypes (Maybe Header) -- header to include for this type (SourceText,FastString) -- the type itself - deriving (Data, Typeable) + deriving (Eq, Data, Typeable) instance Outputable CType where ppr (CType _ mh (_,ct)) = hDoc <+> ftext ct diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index a813c48f9c..a61cf1639d 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -282,7 +282,7 @@ basicKnownKeyNames -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word8TyConName, word16TyConName, word32TyConName, word64TyConName, + word16TyConName, word32TyConName, word64TyConName, -- Others otherwiseIdName, inlineIdName, @@ -1117,8 +1117,7 @@ int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey -- Word module -word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name -word8TyConName = tcQual gHC_WORD (fsLit "Word8") word8TyConKey +word16TyConName, word32TyConName, word64TyConName :: Name word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey @@ -1570,7 +1569,8 @@ instanceOfTyConKey = mkPreludeTyConUnique 184 charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey :: Unique + word8DataConKey, ioDataConKey, integerDataConKey, eqBoxDataConKey, + coercibleDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 doubleDataConKey = mkPreludeDataConUnique 3 @@ -1580,6 +1580,7 @@ intDataConKey = mkPreludeDataConUnique 6 integerSDataConKey = mkPreludeDataConUnique 7 nilDataConKey = mkPreludeDataConUnique 11 ratioDataConKey = mkPreludeDataConUnique 12 +word8DataConKey = mkPreludeDataConUnique 13 stableNameDataConKey = mkPreludeDataConUnique 14 trueDataConKey = mkPreludeDataConUnique 15 wordDataConKey = mkPreludeDataConUnique 16 diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 5ccfaeb3e8..cd65385bb4 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -33,7 +33,8 @@ templateHaskellNames = [ -- Lit charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName, -- Pat litPName, varPName, tupPName, unboxedTupPName, conPName, tildePName, bangPName, infixPName, @@ -82,6 +83,7 @@ templateHaskellNames = [ forallTName, varTName, conTName, appTName, equalityTName, tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, namedWildCardTName, -- TyLit numTyLitName, strTyLitName, -- TyVarBndr @@ -188,7 +190,8 @@ unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey -------------------- TH.Lib ----------------------- -- data Lit = ... charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName :: Name + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName :: Name charLName = libFun (fsLit "charL") charLIdKey stringLName = libFun (fsLit "stringL") stringLIdKey integerLName = libFun (fsLit "integerL") integerLIdKey @@ -197,6 +200,8 @@ wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey rationalLName = libFun (fsLit "rationalL") rationalLIdKey +stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey +charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey -- data Pat = ... litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, @@ -355,7 +360,8 @@ varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, listTName, appTName, sigTName, equalityTName, litTName, promotedTName, promotedTupleTName, - promotedNilTName, promotedConsTName :: Name + promotedNilTName, promotedConsTName, + wildCardTName, namedWildCardTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey varTName = libFun (fsLit "varT") varTIdKey conTName = libFun (fsLit "conT") conTIdKey @@ -371,6 +377,9 @@ promotedTName = libFun (fsLit "promotedT") promotedTIdKey promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey +wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey +namedWildCardTName = libFun (fsLit "namedWildCardT") namedWildCardTIdKey + -- data TyLit = ... numTyLitName, strTyLitName :: Name @@ -556,7 +565,8 @@ unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212 -- data Lit = ... charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, - floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, + charPrimLIdKey:: Unique charLIdKey = mkPreludeMiscIdUnique 220 stringLIdKey = mkPreludeMiscIdUnique 221 integerLIdKey = mkPreludeMiscIdUnique 222 @@ -565,9 +575,11 @@ wordPrimLIdKey = mkPreludeMiscIdUnique 224 floatPrimLIdKey = mkPreludeMiscIdUnique 225 doublePrimLIdKey = mkPreludeMiscIdUnique 226 rationalLIdKey = mkPreludeMiscIdUnique 227 +stringPrimLIdKey = mkPreludeMiscIdUnique 228 +charPrimLIdKey = mkPreludeMiscIdUnique 229 liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 228 +liftStringIdKey = mkPreludeMiscIdUnique 230 -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, @@ -722,7 +734,8 @@ varStrictTKey = mkPreludeMiscIdUnique 375 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey, - promotedNilTIdKey, promotedConsTIdKey :: Unique + promotedNilTIdKey, promotedConsTIdKey, + wildCardTIdKey, namedWildCardTIdKey :: Unique forallTIdKey = mkPreludeMiscIdUnique 380 varTIdKey = mkPreludeMiscIdUnique 381 conTIdKey = mkPreludeMiscIdUnique 382 @@ -738,35 +751,37 @@ promotedTIdKey = mkPreludeMiscIdUnique 391 promotedTupleTIdKey = mkPreludeMiscIdUnique 392 promotedNilTIdKey = mkPreludeMiscIdUnique 393 promotedConsTIdKey = mkPreludeMiscIdUnique 394 +wildCardTIdKey = mkPreludeMiscIdUnique 395 +namedWildCardTIdKey = mkPreludeMiscIdUnique 396 -- data TyLit = ... numTyLitIdKey, strTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 395 -strTyLitIdKey = mkPreludeMiscIdUnique 396 +numTyLitIdKey = mkPreludeMiscIdUnique 400 +strTyLitIdKey = mkPreludeMiscIdUnique 401 -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 397 -kindedTVIdKey = mkPreludeMiscIdUnique 398 +plainTVIdKey = mkPreludeMiscIdUnique 402 +kindedTVIdKey = mkPreludeMiscIdUnique 403 -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 400 -representationalRIdKey = mkPreludeMiscIdUnique 401 -phantomRIdKey = mkPreludeMiscIdUnique 402 -inferRIdKey = mkPreludeMiscIdUnique 403 +nominalRIdKey = mkPreludeMiscIdUnique 404 +representationalRIdKey = mkPreludeMiscIdUnique 405 +phantomRIdKey = mkPreludeMiscIdUnique 406 +inferRIdKey = mkPreludeMiscIdUnique 407 -- data Kind = ... varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, starKIdKey, constraintKIdKey :: Unique -varKIdKey = mkPreludeMiscIdUnique 404 -conKIdKey = mkPreludeMiscIdUnique 405 -tupleKIdKey = mkPreludeMiscIdUnique 406 -arrowKIdKey = mkPreludeMiscIdUnique 407 -listKIdKey = mkPreludeMiscIdUnique 408 -appKIdKey = mkPreludeMiscIdUnique 409 -starKIdKey = mkPreludeMiscIdUnique 410 -constraintKIdKey = mkPreludeMiscIdUnique 411 +varKIdKey = mkPreludeMiscIdUnique 408 +conKIdKey = mkPreludeMiscIdUnique 409 +tupleKIdKey = mkPreludeMiscIdUnique 410 +arrowKIdKey = mkPreludeMiscIdUnique 411 +listKIdKey = mkPreludeMiscIdUnique 412 +appKIdKey = mkPreludeMiscIdUnique 413 +starKIdKey = mkPreludeMiscIdUnique 414 +constraintKIdKey = mkPreludeMiscIdUnique 415 -- data Callconv = ... cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 8d538efda7..64f212d4e9 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -42,6 +42,9 @@ module TysWiredIn ( -- * Word wordTyCon, wordDataCon, wordTyConName, wordTy, + -- * Word8 + word8TyCon, word8DataCon, word8TyConName, word8Ty, + -- * List listTyCon, listTyCon_RDR, listTyConName, listTyConKey, nilDataCon, nilDataConName, nilDataConKey, @@ -155,6 +158,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , floatTyCon , intTyCon , wordTyCon + , word8TyCon , listTyCon , parrTyCon , eqTyCon @@ -209,9 +213,13 @@ listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") li nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon -wordTyConName, wordDataConName, floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name +wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon +word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon +word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon + +floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon @@ -658,6 +666,16 @@ wordTyCon = pcNonRecDataTyCon wordTyConName wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon +word8Ty :: Type +word8Ty = mkTyConTy word8TyCon + +word8TyCon :: TyCon +word8TyCon = pcNonRecDataTyCon word8TyConName + (Just (CType "" Nothing ("HsWord8", fsLit "HsWord8"))) [] + [word8DataCon] +word8DataCon :: DataCon +word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon + floatTy :: Type floatTy = mkTyConTy floatTyCon diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 162063e447..9b107f2053 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1919,16 +1919,43 @@ primop CasMutVarOp "casMutVar#" GenPrimOp section "Exceptions" ------------------------------------------------------------------------ +{- Note [Strictness for mask/unmask/catch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example, which comes from GHC.IO.Handle.Internals: + wantReadableHandle3 f ma b st + = case ... of + DEFAULT -> case ma of MVar a -> ... + 0# -> maskAsynchExceptions# (\st -> case ma of MVar a -> ...) +The outer case just decides whether to mask exceptions, but we don't want +thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd. + +For catch, we know that the first branch will be evaluated, but not +necessarily the second. Hence strictApply1Dmd and lazyApply1Dmd + +Howver, consider + catch# (\st -> case x of ...) (..handler..) st +We'll see that the entire thing is strict in 'x', so 'x' may be evaluated +before the catch#. So fi evaluting 'x' causes a divide-by-zero exception, +it won't be caught. This seems acceptable: + - x might be evaluated somewhere else outside the catch# anyway + - It's an imprecise eception anyway. Synchronous exceptions (in the + IO monad) will never move in this way. +There was originally a comment + "Catch is actually strict in its first argument + but we don't want to tell the strictness + analyser about that, so that exceptions stay inside it." +but tracing it back through the commit logs did not give any +rationale. And making catch# lazy has performance costs for everyone. +-} + primop CatchOp "catch#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld -> (# State# RealWorld, a #) with - -- Catch is actually strict in its first argument - -- but we don't want to tell the strictness - -- analyser about that, so that exceptions stay inside it. - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,lazyApply2Dmd,topDmd] topRes } + -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -1965,7 +1992,8 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -1973,7 +2001,7 @@ primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1981,7 +2009,8 @@ primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2001,7 +2030,8 @@ primop AtomicallyOp "atomically#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2027,7 +2057,8 @@ primop CatchRetryOp "catchRetry#" GenPrimOp -> (State# RealWorld -> (# State# RealWorld, a #) ) -> (State# RealWorld -> (# State# RealWorld, a #) ) with - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,lazyApply1Dmd,topDmd] topRes } + -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2036,7 +2067,8 @@ primop CatchSTMOp "catchSTM#" GenPrimOp -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) -> (State# RealWorld -> (# State# RealWorld, a #) ) with - strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,lazyApply2Dmd,topDmd] topRes } + -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2439,25 +2471,35 @@ primop TagToEnumOp "tagToEnum#" GenPrimOp ------------------------------------------------------------------------ section "Bytecode operations" - {Support for the bytecode interpreter and linker.} + {Support for manipulating bytecode objects used by the interpreter and + linker. + + Bytecode objects are heap objects which represent top-level bindings and + contain a list of instructions and data needed by these instructions.} ------------------------------------------------------------------------ primtype BCO# - {Primitive bytecode type.} + { Primitive bytecode type. } primop AddrToAnyOp "addrToAny#" GenPrimOp Addr# -> (# a #) - {Convert an {\tt Addr\#} to a followable Any type.} + { Convert an {\tt Addr\#} to a followable Any type. } with code_size = 0 primop MkApUpd0_Op "mkApUpd0#" GenPrimOp BCO# -> (# a #) + { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of + the BCO when evaluated. } with out_of_line = True primop NewBCOOp "newBCO#" GenPrimOp ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO# #) + { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The + resulting object encodes a function of the given arity with the instructions + encoded in {\tt instrs}, and a static reference table usage bitmap given by + {\tt bitmap}. } with has_side_effects = True out_of_line = True diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 73dfbeb448..9f5c07662a 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1015,9 +1015,10 @@ lookupQualifiedNameGHCi rdr_name , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] = do { res <- loadSrcInterface_maybe doc mod False Nothing ; case res of - Succeeded iface + Succeeded ifaces -> return [ name - | avail <- mi_exports iface + | iface <- ifaces + , avail <- mi_exports iface , name <- availNames avail , nameOccName name == occ ] diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index d7c3d39aa8..aeb0388673 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -229,11 +229,15 @@ rnImportDecl this_mod | otherwise -> whenWOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) - iface <- loadSrcInterface doc imp_mod_name want_boot (fmap snd mb_pkg) + ifaces <- loadSrcInterface doc imp_mod_name want_boot (fmap snd mb_pkg) -- Compiler sanity check: if the import didn't say -- {-# SOURCE #-} we should not get a hi-boot file - WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do + WARN( not want_boot && any mi_boot ifaces, ppr imp_mod_name ) do + + -- Another sanity check: we should not get multiple interfaces + -- if we're looking for an hi-boot file + WARN( want_boot && length ifaces /= 1, ppr imp_mod_name ) do -- Issue a user warning for a redundant {- SOURCE -} import -- NB that we arrange to read all the ordinary imports before @@ -244,7 +248,7 @@ rnImportDecl this_mod -- the non-boot module depends on the compilation order, which -- is not deterministic. The hs-boot test can show this up. dflags <- getDynFlags - warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) + warnIf (want_boot && any (not.mi_boot) ifaces && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ addErr (ptext (sLit "safe import can't be used as Safe Haskell isn't on!") @@ -257,7 +261,7 @@ rnImportDecl this_mod is_dloc = loc, is_as = qual_mod_name } -- filter the imports according to the import declaration - (new_imp_details, gres) <- filterImports iface imp_spec imp_details + (new_imp_details, gres) <- filterImports ifaces imp_spec imp_details let gbl_env = mkGlobalRdrEnv gres @@ -272,13 +276,17 @@ rnImportDecl this_mod || (implicit && safeImplicitImpsReq dflags) let imports - = (calculateAvails dflags iface mod_safe' want_boot) { + = foldr plusImportAvails emptyImportAvails (map + (\iface -> + (calculateAvails dflags iface mod_safe' want_boot) { imp_mods = unitModuleEnv (mi_module iface) - [(qual_mod_name, import_all, loc, mod_safe')] } + [(qual_mod_name, import_all, loc, mod_safe')] }) + ifaces) -- Complain if we import a deprecated module whenWOptM Opt_WarnWarningsDeprecations ( - case (mi_warns iface) of + forM_ ifaces $ \iface -> + case mi_warns iface of WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt _ -> return () ) @@ -286,7 +294,7 @@ rnImportDecl this_mod let new_imp_decl = L loc (decl { ideclSafe = mod_safe' , ideclHiding = new_imp_details }) - return (new_imp_decl, gbl_env, imports, mi_hpc iface) + return (new_imp_decl, gbl_env, imports, any mi_hpc ifaces) -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. @@ -654,18 +662,18 @@ although we never look up data constructors. -} filterImports - :: ModIface + :: [ModIface] -> ImpDeclSpec -- The span for the entire import decl -> Maybe (Bool, Located [LIE RdrName]) -- Import spec; True => hiding -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names [GlobalRdrElt]) -- Same again, but in GRE form filterImports iface decl_spec Nothing - = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) + = return (Nothing, gresFromAvails (Just imp_spec) (concatMap mi_exports iface)) where imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } -filterImports iface decl_spec (Just (want_hiding, L l import_items)) +filterImports ifaces decl_spec (Just (want_hiding, L l import_items)) = do -- check for errors, convert RdrNames to Names items1 <- mapM lookup_lie import_items @@ -684,7 +692,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) return (Just (want_hiding, L l (map fst items2)), gres) where - all_avails = mi_exports iface + all_avails = concatMap mi_exports ifaces -- See Note [Dealing with imports] imp_occ_env :: OccEnv (Name, -- the name @@ -733,7 +741,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) Succeeded a -> return (Just a) lookup_err_msg err = case err of - BadImport -> badImportItemErr iface decl_spec ieRdr all_avails + BadImport -> badImportItemErr (any mi_boot ifaces) decl_spec + ieRdr all_avails IllegalImport -> illegalImportItemErr QualImportError rdr -> qualImportItemErr rdr @@ -1572,13 +1581,13 @@ printMinimalImports imports_w_usage = do { let ImportDecl { ideclName = L _ mod_name , ideclSource = is_boot , ideclPkgQual = mb_pkg } = decl - ; iface <- loadSrcInterface doc mod_name is_boot (fmap snd mb_pkg) - ; let lies = map (L l) (concatMap (to_ie iface) used) + ; ifaces <- loadSrcInterface doc mod_name is_boot (fmap snd mb_pkg) + ; let lies = map (L l) (concatMap (to_ie ifaces) used) ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } where doc = text "Compute minimal imports for" <+> ppr decl - to_ie :: ModIface -> AvailInfo -> [IE Name] + to_ie :: [ModIface] -> AvailInfo -> [IE Name] -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -1586,8 +1595,9 @@ printMinimalImports imports_w_usage = [IEVar (noLoc n)] to_ie _ (AvailTC n [m]) | n==m = [IEThingAbs (noLoc n)] - to_ie iface (AvailTC n ns) - = case [xs | AvailTC x xs <- mi_exports iface + to_ie ifaces (AvailTC n ns) + = case [xs | iface <- ifaces + , AvailTC x xs <- mi_exports iface , x == n , x `elem` xs -- Note [Partial export] ] of @@ -1631,43 +1641,52 @@ qualImportItemErr rdr = hang (ptext (sLit "Illegal qualified name in import item:")) 2 (ppr rdr) -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc -badImportItemErrStd iface decl_spec ie +badImportItemErrStd :: IsBootInterface -> ImpDeclSpec -> IE RdrName -> SDoc +badImportItemErrStd is_boot decl_spec ie = sep [ptext (sLit "Module"), quotes (ppr (is_mod decl_spec)), source_import, ptext (sLit "does not export"), quotes (ppr ie)] where - source_import | mi_boot iface = ptext (sLit "(hi-boot interface)") + source_import | is_boot = ptext (sLit "(hi-boot interface)") | otherwise = Outputable.empty -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc -badImportItemErrDataCon dataType iface decl_spec ie +badImportItemErrDataCon :: OccName + -> IsBootInterface + -> ImpDeclSpec + -> IE RdrName + -> SDoc +badImportItemErrDataCon dataType_occ is_boot decl_spec ie = vcat [ ptext (sLit "In module") <+> quotes (ppr (is_mod decl_spec)) <+> source_import <> colon , nest 2 $ quotes datacon <+> ptext (sLit "is a data constructor of") - <+> quotes (ppr dataType) + <+> quotes dataType , ptext (sLit "To import it use") , nest 2 $ quotes (ptext (sLit "import")) <+> ppr (is_mod decl_spec) - <> parens_sp (ppr dataType <> parens_sp datacon) + <> parens_sp (dataType <> parens_sp datacon) , ptext (sLit "or") , nest 2 $ quotes (ptext (sLit "import")) <+> ppr (is_mod decl_spec) - <> parens_sp (ppr dataType <> ptext (sLit "(..)")) + <> parens_sp (dataType <> ptext (sLit "(..)")) ] where datacon_occ = rdrNameOcc $ ieName ie datacon = parenSymOcc datacon_occ (ppr datacon_occ) - source_import | mi_boot iface = ptext (sLit "(hi-boot interface)") + dataType = parenSymOcc dataType_occ (ppr dataType_occ) + source_import | is_boot = ptext (sLit "(hi-boot interface)") | otherwise = Outputable.empty parens_sp d = parens (space <> d <> space) -- T( f,g ) -badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc -badImportItemErr iface decl_spec ie avails +badImportItemErr :: IsBootInterface + -> ImpDeclSpec + -> IE RdrName + -> [AvailInfo] + -> SDoc +badImportItemErr is_boot decl_spec ie avails = case find checkIfDataCon avails of - Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie - Nothing -> badImportItemErrStd iface decl_spec ie + Just con -> badImportItemErrDataCon (availOccName con) is_boot decl_spec ie + Nothing -> badImportItemErrStd is_boot decl_spec ie where checkIfDataCon (AvailTC _ ns) = case find (\n -> importedFS == nameOccNameFS n) ns of @@ -1769,11 +1788,11 @@ missingImportListItem ie moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt _ txt) = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"), - nest 2 (vcat (map ppr txt)) ] + nest 2 (vcat (map (ppr . snd . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt) = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <+> ptext (sLit "is deprecated:"), - nest 2 (vcat (map ppr txt)) ] + nest 2 (vcat (map (ppr . snd . unLoc) txt)) ] packageImportErr :: SDoc packageImportErr diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index f5ffcd7c04..9ad8b1e41d 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -43,7 +43,6 @@ import DynFlags import HscTypes ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq, removeDups ) import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) -import Util ( mapSnd ) import Control.Monad import Data.List( partition, sortBy ) @@ -71,21 +70,21 @@ Checks the @(..)@ etc constraints in the export list. -- Brings the binders of the group into scope in the appropriate places; -- does NOT assume that anything is in scope already -rnSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, - hs_splcds = splice_decls, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_docs = docs }) +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_docs = docs }) = do { -- (A) Process the fixity declarations, creating a mapping from -- FastStrings to FixItems. @@ -147,7 +146,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. traceRn (text "Start rnTyClDecls") ; - (rn_tycl_decls, src_fvs1) <- rnTyClDecls extra_deps tycl_decls ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; @@ -930,7 +929,7 @@ doing dependency analysis when compiling A.hs To handle this problem, we add a dependency - from every local declaration - to everything that comes from this module's .hs-boot file. -In this case, we'll add and edges +In this case, we'll ad and edges - from A2 to A1 (but that edge is there already) - from A1 to A1 (which is new) @@ -949,26 +948,35 @@ See also Note [Grouping of type and class declarations] in TcTyClsDecls. -} -rnTyClDecls :: Maybe FreeVars -> [TyClGroup RdrName] +rnTyClDecls :: [TyClGroup RdrName] -> RnM ([TyClGroup Name], FreeVars) -- Rename the declarations and do depedency analysis on them -rnTyClDecls extra_deps tycl_ds - = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds) +rnTyClDecls tycl_ds + = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds) ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs) ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds) - ; this_mod <- getModule - ; let add_boot_deps :: FreeVars -> FreeVars + ; tcg_env <- getGblEnv + ; let this_mod = tcg_mod tcg_env + boot_info = tcg_self_boot tcg_env + + add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)] -- See Note [Extra dependencies from .hs-boot files] - add_boot_deps fvs - | Just extra <- extra_deps - , has_local_imports fvs = fvs `plusFV` extra - | otherwise = fvs + add_boot_deps ds_w_fvs + = case boot_info of + SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs) + -> map (add_one tcs) ds_w_fvs + _ -> ds_w_fvs + + add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars) + add_one tcs pr@(decl,fvs) + | has_local_imports fvs = (decl, fvs `plusFV` tcs) + | otherwise = pr has_local_imports fvs = foldNameSet ((||) . nameIsHomePackageImport this_mod) False fvs - ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs + ds_w_fvs' = add_boot_deps ds_w_fvs sccs :: [SCC (LTyClDecl Name)] sccs = depAnalTyClDecls ds_w_fvs' diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 61b5b14ab4..073ddaa121 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -45,6 +45,7 @@ import Hooks import Var ( Id ) import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) +import RnTypes ( collectWildCards ) import Util import {-# SOURCE #-} TcExpr ( tcMonoExpr ) @@ -130,7 +131,7 @@ rn_bracket _ (DecBrL decls) -- The emptyDUs is so that we just collect uses for this -- group alone in the call to rnSrcDecls below ; (tcg_env, group') <- setGblEnv new_gbl_env $ - rnSrcDecls Nothing group + rnSrcDecls group -- Discard the tcg_env; it contains only extra info about fixity ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$ @@ -420,11 +421,70 @@ rnSpliceType splice k run_type_splice rn_splice = do { hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 + ; checkValidPartialTypeSplice doc hs_ty2 + -- See Note [Partial Type Splices] ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] ; return (HsParTy hs_ty3, fvs) } -- Wrap the result of the splice in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) +{- +Note [Partial Type Splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Partial Type Signatures are partially supported in TH type splices: only +anonymous wild cards are allowed. + +Normally, named wild cards are collected before renaming a (partial) type +signature. However, TH type splices are run during renaming, i.e. after the +initial traversal, leading to out of scope errors for named wild cards. We +can't just extend the initial traversal to collect the named wild cards in TH +type splices, as we'd need to expand them, which is supposed to happen only +once, during renaming. + +Similarly, the extra-constraints wild card is handled right before renaming +too, and is therefore also not supported in a TH type splice. Another reason +to forbid extra-constraints wild cards in TH type splices is that a single +signature can contain many TH type splices, whereas it mustn't contain more +than one extra-constraints wild card. Enforcing would this be hard the way +things are currently organised. + +Anonymous wild cards pose no problem, because they start out without names and +are given names during renaming. These names are collected right after +renaming. The names generated for anonymous wild cards in TH type splices will +thus be collected as well. + +For more details about renaming wild cards, see rnLHsTypeWithWildCards. + +Note that partial type signatures are fully supported in TH declaration +splices, e.g.: + + [d| foo :: _ => _ + foo x y = x == y |] + +This is because in this case, the partial type signature can be treated as a +whole signature, instead of as an arbitray type. + +-} + +-- | Check that the type splice doesn't contain an extra-constraint wild card. +-- See Note [Partial Type Splices]. Named wild cards aren't supported in type +-- splices either, but they will be caught during renaming, as they won't be +-- in scope. +-- +-- Note that without this check, an error would still be reported, but it +-- would tell the user an unexpected wild card was encountered. This message +-- is confusing, as it doesn't mention the wild card was unexpected because it +-- was an extra-constraints wild card. To avoid confusing, this function +-- provides a specific error message for this case. +checkValidPartialTypeSplice :: HsDocContext -> LHsType RdrName -> RnM () +checkValidPartialTypeSplice doc ty + | (L loc _extraWc : _, _) <- collectWildCards ty + = failAt loc $ hang (text "Invalid partial type:") 2 (ppr ty) $$ + text "An extra-constraints wild card is not allowed in a type splice" $$ + docOfHsDocContext doc + | otherwise + = return () ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat] diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index ac2982ba4f..346d764444 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -13,7 +13,7 @@ module RnTypes ( rnHsKind, rnLHsKind, rnLHsMaybeKind, rnHsSigType, rnLHsInstType, rnConDeclFields, newTyVarNameRn, rnLHsTypeWithWildCards, - rnHsSigTypeWithWildCards, + rnHsSigTypeWithWildCards, collectWildCards, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, @@ -542,7 +542,17 @@ dataKindsErr is_type thing -- cards to bind. rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars, [Name]) -rnHsSigTypeWithWildCards doc_str = rnLHsTypeWithWildCards (TypeSigCtx doc_str) +rnHsSigTypeWithWildCards doc_str ty + = rnLHsTypeWithWildCards (TypeSigCtx doc_str) ty' + where + ty' = extractExtraCtsWc `fmap` flattenTopLevelLHsForAllTy ty + -- When there is a wild card at the end of the context, remove it and add + -- its location as the extra-constraints wild card in the HsForAllTy. + extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty) + | Just (ctxt', ct) <- snocView ctxt + , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct + = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty + extractExtraCtsWc ty = ty -- | Variant of @rnLHsType@ that supports wild cards. The third element of the -- tuple consists of the freshly generated names of the anonymous wild cards @@ -551,31 +561,19 @@ rnHsSigTypeWithWildCards doc_str = rnLHsTypeWithWildCards (TypeSigCtx doc_str) rnLHsTypeWithWildCards :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars, [Name]) rnLHsTypeWithWildCards doc ty - = do { -- When there is a wild card at the end of the context, remove it and - -- add its location as the extra-constraints wild card in the - -- HsForAllTy. - let ty' = extractExtraCtsWc `fmap` flattenTopLevelLHsForAllTy ty - - ; checkValidPartialType doc ty' - + = do { checkValidPartialType doc ty ; rdr_env <- getLocalRdrEnv -- Filter out named wildcards that are already in scope - ; let (_, wcs) = collectWildCards ty' + ; let (_, wcs) = collectWildCards ty nwcs = [L loc n | L loc (NamedWildCard n) <- wcs , not (elemLocalRdrEnv n rdr_env) ] ; bindLocatedLocalsRn nwcs $ \nwcs' -> do { - (ty'', fvs) <- rnLHsType doc ty' + (ty', fvs) <- rnLHsType doc ty -- Add the anonymous wildcards that have been given names during -- renaming - ; let (_, wcs') = collectWildCards ty'' + ; let (_, wcs') = collectWildCards ty' awcs = filter (isAnonWildCard . unLoc) wcs' - ; return (ty'', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } } - where - extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty) - | Just (ctxt', ct) <- snocView ctxt - , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct - = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty - extractExtraCtsWc ty = ty + ; return (ty', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } } -- | Extract all wild cards from a type. The named and anonymous -- extra-constraints wild cards are returned separately to be able to give @@ -584,7 +582,7 @@ collectWildCards :: Eq name => LHsType name -> ([Located (HsWildCardInfo name)], -- extra-constraints wild cards [Located (HsWildCardInfo name)]) -- wild cards -collectWildCards lty = (nubBy sameWildCard extra, nubBy sameWildCard wcs) +collectWildCards lty = (extra, nubBy sameNamedWildCard wcs) where (extra, wcs) = go lty go (L loc ty) = case ty of @@ -648,10 +646,21 @@ checkValidPartialType doc lty -- If there was a valid extra-constraints wild card, it should have -- already been removed and its location should be stored in the -- HsForAllTy - (if isJust extra - then text "Only a single extra-constraints wild card is allowed" - else fcat [ text "An extra-constraints wild card must occur" - , text "at the end of the constraints" ]) $$ + (case extra of + Just _ -> + -- We're in a top-level context with an extracted + -- extra-constraints wild card. + text "Only a single extra-constraints wild card is allowed" + _ | TypeSigCtx _ <- doc -> + -- We're in a top-level context, but the extra-constraints wild + -- card didn't occur at the end. + fcat [ text "An extra-constraints wild card must occur" + , text "at the end of the constraints" ] + _ -> + -- We're not in a top-level context, so no extra-constraints + -- wild cards are supported. + fcat [ text "An extra-constraints wild card is only allowed" + , text "in the top-level context" ]) $$ docOfHsDocContext doc ; whenNonEmpty isAnonWildCard inCtxt $ \(L loc _) -> diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 88ca00f6a0..a6672507a9 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -19,8 +19,8 @@ import Rules ( mkRuleBase, unionRuleBase, import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo -import CoreUtils ( coreBindsSize, coreBindsStats, exprSize, - mkTicks, stripTicksTop ) +import CoreStats ( coreBindsSize, coreBindsStats, exprSize ) +import CoreUtils ( mkTicks, stripTicksTop ) import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult, lintAnnots ) import Simplify ( simplTopBinds, simplExpr, simplRule ) diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index afa9d9f38d..1f21cb79a2 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -45,7 +45,7 @@ import Id import IdInfo ( SpecInfo( SpecInfo ) ) import VarEnv import VarSet -import Name ( Name, NamedThing(..), nameIsLocalOrFrom, nameOccName ) +import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import NameSet import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..), MatchResult'(..), noLazyEqs ) @@ -180,9 +180,12 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs lhs_names = nameSetElems (extendNameSet (exprsOrphNames args) fn) -- TODO: copied from ruleLhsOrphNames - orph = case filter (nameIsLocalOrFrom this_mod) lhs_names of - (n : _) -> NotOrphan (nameOccName n) - [] -> IsOrphan + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filter (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] @@ -477,7 +480,7 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) -- then (f args) matches the rule, and the corresponding -- rewritten RHS is rhs -- --- The bndrs and rhs is occurrence-analysed +-- The returned expression is occurrence-analysed -- -- Example -- @@ -499,8 +502,9 @@ matchRule dflags rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems = case match_fn dflags rule_env fn args of - Just expr -> Just expr Nothing -> Nothing + Just expr -> Just (occurAnalyseExpr expr) + -- We could do this when putting things into the rulebase, I guess matchRule _ in_scope is_active _ args rough_args (Rule { ru_act = act, ru_rough = tpl_tops diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index e5e3ec97b1..cea53a072f 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -584,8 +584,7 @@ specProgram guts@(ModGuts { mg_module = this_mod -- Specialise imported functions ; hpt_rules <- getRuleBase ; let rule_base = extendRuleBaseList hpt_rules local_rules - - ; (new_rules, spec_binds) <- specImports dflags this_mod emptyVarSet + ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet rule_base (ud_calls uds) -- Don't forget to wrap the specialized bindings with bindings @@ -606,13 +605,13 @@ specProgram guts@(ModGuts { mg_module = this_mod -- accidentally re-use a unique that's already in use -- Easiest thing is to do it all at once, as if all the top-level -- decls were mutually recursive - top_subst = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $ - bindersOfBinds binds - , se_interesting = emptyVarSet } + top_env = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $ + bindersOfBinds binds + , se_interesting = emptyVarSet } go [] = return ([], emptyUDs) go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_subst bind uds + (bind', uds') <- specBind top_env bind uds return (bind' ++ binds', uds') {- @@ -639,6 +638,7 @@ See Trac #10491 -- | Specialise a set of calls to imported bindings specImports :: DynFlags -> Module + -> SpecEnv -- Passed in so that all top-level Ids are in scope -> VarSet -- Don't specialise these ones -- See Note [Avoiding recursive specialisation] -> RuleBase -- Rules from this module and the home package @@ -647,7 +647,7 @@ specImports :: DynFlags -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings -- See Note [Wrapping bindings returned by specImports] -specImports dflags this_mod done rule_base cds +specImports dflags this_mod top_env done rule_base cds -- See Note [Disabling cross-module specialisation] | not $ gopt Opt_CrossModuleSpecialise dflags = return ([], []) @@ -660,20 +660,21 @@ specImports dflags this_mod done rule_base cds go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) go _ [] = return ([], []) go rb (CIS fn calls_for_fn : other_calls) - = do { (rules1, spec_binds1) <- specImport dflags this_mod done rb fn $ + = do { (rules1, spec_binds1) <- specImport dflags this_mod top_env done rb fn $ Map.toList calls_for_fn ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } specImport :: DynFlags -> Module + -> SpecEnv -- Passed in so that all top-level Ids are in scope -> VarSet -- Don't specialise these -- See Note [Avoiding recursive specialisation] -> RuleBase -- Rules from this module -> Id -> [CallInfo] -- Imported function and calls for it -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings -specImport dflags this_mod done rb fn calls_for_fn +specImport dflags this_mod top_env done rb fn calls_for_fn | fn `elemVarSet` done = return ([], []) -- No warning. This actually happens all the time -- when specialising a recursive function, because @@ -694,16 +695,17 @@ specImport dflags this_mod done rb fn calls_for_fn ; let full_rb = unionRuleBase rb (eps_rule_base eps) rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn - ; (rules1, spec_pairs, uds) <- runSpecM dflags this_mod $ - specCalls (Just this_mod) emptySpecEnv rules_for_fn calls_for_fn fn rhs + ; (rules1, spec_pairs, uds) <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $ + runSpecM dflags this_mod $ + specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] -- After the rules kick in we may get recursion, but -- we rely on a global GlomBinds to sort that out later -- See Note [Glom the bindings if imported functions are specialised] -- Now specialise any cascaded calls - ; (rules2, spec_binds2) <- -- pprTrace "specImport" (ppr fn $$ ppr uds $$ ppr rhs) $ - specImports dflags this_mod (extendVarSet done fn) + ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $ + specImports dflags this_mod top_env (extendVarSet done fn) (extendRuleBaseList rb rules1) (ud_calls uds) @@ -807,9 +809,6 @@ data SpecEnv -- See Note [Interesting dictionary arguments] } -emptySpecEnv :: SpecEnv -emptySpecEnv = SE { se_subst = CoreSubst.emptySubst, se_interesting = emptyVarSet} - specVar :: SpecEnv -> Id -> CoreExpr specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 6c6d4bfb1d..d04a15791a 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -174,7 +174,7 @@ function. (If the arguments were expressions, we would have to build their closures first.) There is no constructor for a lone variable; it would appear as -@StgApp var [] _@. +@StgApp var []@. -} type GenStgLiveVars occ = UniqSet occ @@ -191,7 +191,7 @@ data GenStgExpr bndr occ * * ************************************************************************ -There are a specialised forms of application, for constructors, +There are specialised forms of application, for constructors, primitives, and literals. -} diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 79dd492ce7..41d9abb921 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -220,8 +220,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr id_dmds = addCaseBndrDmd case_bndr_dmd dmds - alt_ty3 | io_hack_reqd dc bndrs = deferAfterIO alt_ty2 - | otherwise = alt_ty2 + alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2 + | otherwise = alt_ty2 -- Compute demand on the scrutinee -- See Note [Demand on scrutinee of a product case] @@ -292,29 +292,16 @@ dmdAnal' env dmd (Let (Rec pairs) body) body_ty2 `seq` (body_ty2, Let (Rec pairs') body') -io_hack_reqd :: DataCon -> [Var] -> Bool --- Note [IO hack in the demand analyser] --- --- There's a hack here for I/O operations. Consider --- case foo x s of { (# s, r #) -> y } --- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O --- operation that simply terminates the program (not in an erroneous way)? --- In that case we should not evaluate 'y' before the call to 'foo'. --- Hackish solution: spot the IO-like situation and add a virtual branch, --- as if we had --- case foo x s of --- (# s, r #) -> y --- other -> return () --- So the 'y' isn't necessarily going to be evaluated --- --- A more complete example (Trac #148, #1592) where this shows up is: --- do { let len = <expensive> ; --- ; when (...) (exitWith ExitSuccess) --- ; print len } -io_hack_reqd con bndrs +io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool +-- See Note [IO hack in the demand analyser] +io_hack_reqd scrut con bndrs | (bndr:_) <- bndrs - = con == unboxedPairDataCon && - idType bndr `eqType` realWorldStatePrimTy + , con == unboxedPairDataCon + , idType bndr `eqType` realWorldStatePrimTy + , (fun, _) <- collectArgs scrut + = case fun of + Var f -> not (isPrimOpId f) + _ -> True | otherwise = False @@ -350,8 +337,48 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) id_dmds = addCaseBndrDmd case_bndr_dmd dmds = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) -{- Note [Demand on the scrutinee of a product case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +{- Note [IO hack in the demand analyser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a hack here for I/O operations. Consider + case foo x s of { (# s, r #) -> y } +Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O +operation that simply terminates the program (not in an erroneous way)? +In that case we should not evaluate 'y' before the call to 'foo'. +Hackish solution: spot the IO-like situation and add a virtual branch, +as if we had + case foo x s of + (# s, r #) -> y + other -> return () +So the 'y' isn't necessarily going to be evaluated + +A more complete example (Trac #148, #1592) where this shows up is: + do { let len = <expensive> ; + ; when (...) (exitWith ExitSuccess) + ; print len } + +However, consider + f x s = case getMaskingState# s of + (# s, r #) -> + case x of I# x2 -> ... + +Here it is terribly sad to make 'f' lazy in 's'. After all, +getMaskingState# is not going to diverge or throw an exception! This +situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle +(on an MVar not an Int), and make a material difference. + +So if the scrutinee is a primop call, we *don't* apply the +state hack: + - If is a simple, terminating one like getMaskingState, + applying the hack is over-conservative. + - If the primop is raise# then it returns bottom, so + the case alternatives are alraedy discarded. + - If the primop can raise a non-IO exception, like + divide by zero or seg-fault (eg writing an array + out of bounds) then we don't mind evaluating 'x' first. + +Note [Demand on the scrutinee of a product case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When figuring out the demand on the scrutinee of a product case, we use the demands of the case alternative, i.e. id_dmds. But note that these include the demand on the case binder; diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index 304a3cbacb..b442f3d9a9 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -635,7 +635,9 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co) ; return ( True , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)] - , \ body -> mkUnpackCase body co work_uniq data_con [arg] (Var arg) + , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg) + -- varToCoreExpr important here: arg can be a coercion + -- Lacking this caused Trac #10658 , arg_ty1 ) } | otherwise -- The general case diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 57cfb8b8a8..e67a79e4b5 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -32,6 +32,7 @@ import Maybes import TcMType import TcType import Name +import Panic import Control.Monad import Data.Map (Map) import qualified Data.Map as Map @@ -134,7 +135,8 @@ checkFamInstConsistency famInstMods directlyImpMods -- all directly imported modules must already have been loaded. modIface mod = case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of - Nothing -> panic "FamInst.checkFamInstConsistency" + Nothing -> panicDoc "FamInst.checkFamInstConsistency" + (ppr mod $$ pprHPT hpt) Just iface -> iface ; hmiModule = mi_module . hm_iface diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index 9d4ef1c72e..a65570081d 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -36,7 +36,7 @@ import FastString import Pair ( Pair(..) ) import Data.List ( nubBy ) -import Data.Maybe ( isJust ) +import Data.Maybe {- ************************************************************************ @@ -104,8 +104,8 @@ data FunDepEqn loc -- Non-empty only for FunDepEqns arising from instance decls , fd_eqs :: [Pair Type] -- Make these pairs of types equal - , fd_pred1 :: PredType -- The FunDepEqn arose from - , fd_pred2 :: PredType -- combining these two constraints + , fd_pred1 :: PredType -- The FunDepEqn arose from + , fd_pred2 :: PredType -- combining these two constraints , fd_loc :: loc } {- @@ -185,7 +185,7 @@ improveFromAnother _ _ _ = [] pprEquation :: FunDepEqn a -> SDoc pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 + nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | Pair t1 t2 <- pairs])] improveFromInstEnv :: InstEnvs @@ -214,29 +214,33 @@ improveFromInstEnv inst_env mk_loc pred -- symmetrically, so it's ok to trim the rough_tcs, -- rather than trimming each inst_tcs in turn , ispec <- instances - , (meta_tvs, eqs) <- checkClsFD fd cls_tvs ispec - emptyVarSet tys trimmed_tcs -- NB: orientation + , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec + tys trimmed_tcs -- NB: orientation , let p_inst = mkClassPred cls (is_tys ispec) ] improveFromInstEnv _ _ _ = [] -checkClsFD :: FunDep TyVar -> [TyVar] -- One functional dependency from the class - -> ClsInst -- An instance template - -> TyVarSet -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate - -- TyVarSet are extra tyvars that can be instantiated - -> [([TyVar], [Pair Type])] +improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class + -> ClsInst -- An instance template + -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -> [([TyVar], [Pair Type])] -- Empty or singleton -checkClsFD fd clas_tvs - (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) - extra_qtvs tys_actual rough_tcs_actual +improveClsFD clas_tvs fd + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) + tys_actual rough_tcs_actual + +-- Compare instance {a,b} C sx sp sy sq +-- with wanted [W] C tx tp ty tq +-- for fundep (x,y -> p,q) from class (C x p y q) +-- If (sx,sy) unifies with (tx,ty), take the subst S -- 'qtvs' are the quantified type variables, the ones which an be instantiated -- to make the types match. For example, given -- class C a b | a->b where ... -- instance C (Maybe x) (Tree x) where .. -- --- and an Inst of form (C (Maybe t1) t2), +-- and a wanted constraint of form (C (Maybe t1) t2), -- then we will call checkClsFD with -- -- is_qtvs = {x}, is_tys = [Maybe x, Tree x] @@ -244,14 +248,6 @@ checkClsFD fd clas_tvs -- -- We can instantiate x to t1, and then we want to force -- (Tree x) [t1/x] ~ t2 --- --- This function is also used when matching two Insts (rather than an Inst --- against an instance decl. In that case, qtvs is empty, and we are doing --- an equality check --- --- This function is also used by InstEnv.badFunDeps, which needs to *unify* --- For the one-sided matching case, the qtvs are just from the template, --- so we get matching | instanceCantMatch rough_tcs_inst rough_tcs_actual = [] -- Filter out ones that can't possibly match, @@ -261,9 +257,10 @@ checkClsFD fd clas_tvs length tys_inst == length clas_tvs , ppr tys_inst <+> ppr tys_actual ) - case tcUnifyTys bind_fn ltys1 ltys2 of + case tcMatchTys qtv_set noLazyEqs ltys1 ltys2 of Nothing -> [] - Just subst | isJust (tcUnifyTys bind_fn rtys1' rtys2') + Just (MatchResult subst _) + | isJust (tcMatchTysX qtv_set subst noLazyEqs rtys1 rtys2) -- Don't include any equations that already hold. -- Reason: then we know if any actual improvement has happened, -- in which case we need to iterate the solver @@ -291,9 +288,8 @@ checkClsFD fd clas_tvs -- work of the ls1/ls2 unification leaving a smaller unification problem where rtys1' = map (substTy subst) rtys1 - rtys2' = map (substTy subst) rtys2 - fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2' + fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 -- Don't discard anything! -- We could discard equal types but it's an overkill to call -- eqType again, since we know for sure that /at least one/ @@ -319,10 +315,6 @@ checkClsFD fd clas_tvs -- Trac #6015, #6068 where qtv_set = mkVarSet qtvs - bind_fn tv | tv `elemVarSet` qtv_set = BindMe - | tv `elemVarSet` extra_qtvs = BindMe - | otherwise = Skolem - (ltys1, rtys1) = instFD fd clas_tvs tys_inst (ltys2, rtys2) = instFD fd clas_tvs tys_actual @@ -563,35 +555,59 @@ The instance decls don't overlap, because the third parameter keeps them separate. But we want to make sure that given any constraint D s1 s2 s3 if s1 matches + +Note [Bogus consistency check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In checkFunDeps we check that a new ClsInst is consistent with all the +ClsInsts in the environment. + +The bogus aspect is discussed in Trac #10675. Currenty it if the two +types are *contradicatory*, using (isNothing . tcUnifyTys). But all +the papers say we should check if the two types are *equal* thus + not (substTys subst rtys1 `eqTypes` substTys subst rtys2) +For now I'm leaving the bogus form because that's the way it has +been for years. -} -checkFunDeps :: InstEnvs -> ClsInst - -> Maybe [ClsInst] -- Nothing <=> ok - -- Just dfs <=> conflict with dfs +checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] +-- The Consistency Check. -- Check whether adding DFunId would break functional-dependency constraints -- Used only for instance decls defined in the module being compiled -checkFunDeps inst_envs ispec - | null bad_fundeps = Nothing - | otherwise = Just bad_fundeps - where - (ins_tvs, clas, ins_tys) = instanceHead ispec - ins_tv_set = mkVarSet ins_tvs - cls_inst_env = classInstances inst_envs clas - bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys - -badFunDeps :: [ClsInst] -> Class - -> TyVarSet -> [Type] -- Proposed new instance type - -> [ClsInst] -badFunDeps cls_insts clas ins_tv_set ins_tys +-- Returns a list of the ClsInst in InstEnvs that are inconsistent +-- with the proposed new ClsInst +checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls + , is_tys = tys1, is_tcs = rough_tcs1 }) + | null fds + = [] + | otherwise = nubBy eq_inst $ - [ ispec | fd <- fds, -- fds is often empty, so do this first! - let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, - ispec <- cls_insts, - notNull (checkClsFD fd clas_tvs ispec ins_tv_set ins_tys trimmed_tcs) - ] + [ ispec | ispec <- cls_insts + , fd <- fds + , is_inconsistent fd ispec ] where - (clas_tvs, fds) = classTvsFds clas - rough_tcs = roughMatchTcs ins_tys + cls_insts = classInstances inst_envs cls + (cls_tvs, fds) = classTvsFds cls + qtv_set1 = mkVarSet qtvs1 + + is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) + | instanceCantMatch trimmed_tcs rough_tcs2 + = False + | otherwise + = case tcUnifyTys bind_fn ltys1 ltys2 of + Nothing -> False + Just subst -> isNothing $ -- Bogus legacy test (Trac #10675) + -- See Note [Bogus consistency check] + tcUnifyTys bind_fn (substTys subst rtys1) (substTys subst rtys2) + + where + trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 + (ltys1, rtys1) = instFD fd cls_tvs tys1 + (ltys2, rtys2) = instFD fd cls_tvs tys2 + qtv_set2 = mkVarSet qtvs2 + bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe + | tv `elemVarSet` qtv_set2 = BindMe + | otherwise = Skolem + eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 -- An single instance may appear twice in the un-nubbed conflict list -- because it may conflict with more than one fundep. E.g. @@ -607,6 +623,8 @@ trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] -- we want to match only on the type ta; so our -- rough-match thing must similarly be filtered. -- Hence, we Nothing-ise the tb and tc types right here +-- +-- Result list is same length as input list, just with more Nothings trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs = zipWith select clas_tvs mb_tcs where diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index cbc5da5b53..899ccbe2fb 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -490,27 +490,26 @@ addLocalInst (home_ie, my_insts) ispec | isGHCi = deleteFromInstEnv home_ie ispec | otherwise = home_ie - (_tvs, cls, tys) = instanceHead ispec -- If we're compiling sig-of and there's an external duplicate -- instance, silently ignore it (that's the instance we're -- implementing!) NB: we still count local duplicate instances -- as errors. -- See Note [Signature files and type class instances] - global_ie - | isJust (tcg_sig_of tcg_env) = emptyInstEnv - | otherwise = eps_inst_env eps - inst_envs = InstEnvs { ie_global = global_ie - , ie_local = home_ie' - , ie_visible = tcVisibleOrphanMods tcg_env } - (matches, _, _) = lookupInstEnv False inst_envs cls tys noLazyEqs - dups = filter (identicalClsInstHead ispec) (map (\(x,_,_) -> x) matches) - - -- Check functional dependencies - ; case checkFunDeps inst_envs ispec of - Just specs -> funDepErr ispec specs - Nothing -> return () + global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv + | otherwise = eps_inst_env eps + inst_envs = InstEnvs { ie_global = global_ie + , ie_local = home_ie' + , ie_visible = tcVisibleOrphanMods tcg_env } + + -- Check for inconsistent functional dependencies + ; let inconsistent_ispecs = checkFunDeps inst_envs ispec + ; unless (null inconsistent_ispecs) $ + funDepErr ispec inconsistent_ispecs -- Check for duplicate instance decls. + ; let (_tvs, cls, tys) = instanceHead ispec + (matches, _, _) = lookupInstEnv False inst_envs cls tys noLazyEqs + dups = filter (identicalClsInstHead ispec) (map (\(x,_,_) -> x) matches) ; unless (null dups) $ dupInstErr ispec (head dups) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 0f1f9348a7..c206804c92 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -9,9 +9,10 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, tcHsBootSigs, tcPolyCheck, - PragFun, tcSpecPrags, tcSpecWrapper, + tcSpecPrags, tcSpecWrapper, tcVectDecls, - TcSigInfo(..), TcSigFun, mkPragFun, + TcSigInfo(..), TcSigFun, + TcPragEnv, mkPragEnv, instTcTySig, instTcTySigFromId, findScopedTyVars, badBootDeclErr, mkExport ) where @@ -292,6 +293,53 @@ and will give a 'wrongThingErr' as a result. But the lookup of A won't fail. The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in tcTyVar, doesn't look inside the TcTyThing. + +Note [Inlining and hs-boot files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example (Trac #10083): + + ---------- RSR.hs-boot ------------ + module RSR where + data RSR + eqRSR :: RSR -> RSR -> Bool + + ---------- SR.hs ------------ + module SR where + import {-# SOURCE #-} RSR + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 + + ---------- RSR.hs ------------ + module RSR where + import SR + data RSR = MkRSR SR -- deriving( Eq ) + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) + +When compiling RSR we get this code + + RSR.eqRSR :: RSR -> RSR -> Bool + RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> + case ds1 of _ { RSR.MkRSR s1 -> + case ds2 of _ { RSR.MkRSR s2 -> + SR.eqSR s1 s2 }} + + RSR.foo :: RSR -> RSR -> Bool + RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) + +Now, when optimising foo: + Inline eqRSR (small, non-rec) + Inline eqSR (small, non-rec) +but the result of inlining eqSR from SR is another call to eqRSR, so +everything repeats. Neither eqSR nor eqRSR are (apparently) loop +breakers. + +Solution: when compiling RSR, add a NOINLINE pragma to every function +exported by the boot-file for RSR (if it exists). + +ALAS: doing so makes the boostrappted GHC itself slower by 8% overall + (on Trac #9872a-d, and T1969. So I un-did this change, and + parked it for now. Sigh. -} tcValBinds :: TopLevelFlag @@ -305,7 +353,19 @@ tcValBinds top_lvl binds sigs thing_inside -- See Note [Placeholder PatSyn kinds] tcTySigs sigs - ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) + ; _self_boot <- tcSelfBootInfo + ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) + +-- ------- See Note [Inlining and hs-boot files] (change parked) -------- +-- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files] +-- , SelfBoot { sb_ids = boot_id_names } <- self_boot +-- = foldNameSet add_no_inl prag_fn1 boot_id_names +-- | otherwise +-- = prag_fn1 +-- add_no_inl boot_id_name prag_fn +-- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name) +-- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma) +-- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module") -- Extend the envt right away with all the Ids -- declared with complete type signatures @@ -327,7 +387,7 @@ tcValBinds top_lvl binds sigs thing_inside = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" ------------------------ -tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun +tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, @@ -348,7 +408,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside ------------------------ tc_group :: forall thing. - TopLevelFlag -> TcSigFun -> PragFun + TopLevelFlag -> TcSigFun -> TcPragEnv -> (RecFlag, LHsBinds Name) -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) @@ -409,7 +469,7 @@ recursivePatSynErr binds pprLoc loc tc_single :: forall thing. - TopLevelFlag -> TcSigFun -> PragFun + TopLevelFlag -> TcSigFun -> TcPragEnv -> LHsBind Name -> TcM thing -> TcM (LHsBinds TcId, thing) tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside @@ -463,7 +523,7 @@ mkEdges sig_fn binds , bndr <- collectHsBindBinders bind ] ------------------------ -tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun +tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures @@ -518,7 +578,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list tcPolyNoGen -- No generalisation whatsoever :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures - -> PragFun -> TcSigFun + -> TcPragEnv -> TcSigFun -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) @@ -533,7 +593,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list = do { mono_ty' <- zonkTcType (idType mono_id) -- Zonk, mainly to expose unboxed types to checkStrictBinds ; let mono_id' = setIdType mono_id mono_ty' - ; _specs <- tcSpecPrags mono_id' (prag_fn name) + ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name) ; return mono_id' } -- NB: tcPrags generates error messages for -- specialisation pragmas for non-overloaded sigs @@ -543,7 +603,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list ------------------ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures - -> PragFun + -> TcPragEnv -> TcSigInfo -> LHsBind Name -> TcM (LHsBinds TcId, [TcId]) @@ -561,7 +621,7 @@ tcPolyCheck rec_tc prag_fn do { ev_vars <- newEvVars theta ; let ctxt = FunSigCtxt name warn_redundant skol_info = SigSkol ctxt (mkPhiTy theta tau) - prag_sigs = prag_fn name + prag_sigs = lookupPragEnv prag_fn name tvs = map snd tvs_w_scoped ; (ev_binds, (binds', [mono_info])) <- setSrcSpan loc $ @@ -589,7 +649,7 @@ tcPolyCheck _rec_tc _prag_fn sig _bind tcPolyInfer :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures - -> PragFun -> TcSigFun + -> TcPragEnv -> TcSigFun -> Bool -- True <=> apply the monomorphism restriction -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) @@ -619,7 +679,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list -- poly_ids are guaranteed zonked by mkExport -------------- -mkExport :: PragFun +mkExport :: TcPragEnv -> [TyVar] -> TcThetaType -- Both already zonked -> MonoBindInfo -> TcM (ABExport Id) @@ -675,7 +735,7 @@ mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id) , abe_mono = mono_id , abe_prags = SpecPrags spec_prags}) } where - prag_sigs = prag_fn poly_name + prag_sigs = lookupPragEnv prag_fn poly_name sig_ctxt = InfSigCtxt poly_name mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id @@ -966,32 +1026,32 @@ Some wrinkles well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags -} -type PragFun = Name -> [LSig Name] - -mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun -mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] +mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv +mkPragEnv sigs binds + = foldl extendPragEnv emptyNameEnv prs where prs = mapMaybe get_sig sigs - get_sig :: LSig Name -> Maybe (Located Name, LSig Name) - get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl)) - get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl)) - get_sig _ = Nothing + get_sig :: LSig Name -> Maybe (Name, LSig Name) + get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl)) + get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl)) + get_sig _ = Nothing - add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function - | Just ar <- lookupNameEnv ar_env n, - Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar } + add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function + | Inline <- inl_inline inl_prag -- add arity only for real INLINE pragmas, not INLINABLE - | otherwise = inl_prag - - prag_env :: NameEnv [LSig Name] - prag_env = foldl add emptyNameEnv prs - add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p + , Just ar <- lookupNameEnv ar_env n + = inl_prag { inl_sat = Just ar } + | otherwise + = inl_prag -- ar_env maps a local to the arity of its definition ar_env :: NameEnv Arity ar_env = foldrBag lhsBindArity emptyNameEnv binds +extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv +extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig + lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env = extendNameEnv env (unLoc id) (matchGroupArity ms) @@ -1015,9 +1075,9 @@ tcSpecPrags poly_id prag_sigs bad_sigs = filter is_bad_sig prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s) - warn_discarded_sigs = warnPrags poly_id bad_sigs $ - ptext (sLit "Discarding unexpected pragmas for") - + warn_discarded_sigs + = addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) bad_sigs))) -------------- tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag] @@ -1148,7 +1208,7 @@ tcVect (HsVect s name rhs) -- turn the vectorisation declaration into a single non-recursive binding ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] sigFun = const Nothing - pragFun = mkPragFun [] (unitBag bind) + pragFun = emptyPragEnv -- perform type inference (including generalisation) ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind] diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 28cf1cab49..b1ea1dad46 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -233,18 +233,13 @@ place to add their superclasses is canonicalisation. See Note [Add superclasses only during canonicalisation]. Here is what we do: Givens: Add all their superclasses as Givens. - They may be needed to prove Wanteds + They may be needed to prove Wanteds. - Wanteds: Do nothing. - - Deriveds: Add all their superclasses as Derived. + Wanteds/Derived: + Add all their superclasses as Derived. The sole reason is to expose functional dependencies in superclasses or equality superclasses. - We only do this in the improvement phase, if solving has - not succeeded; see Note [The improvement story] in - TcInteract - Examples of how adding superclasses as Derived is useful --- Example 1 @@ -264,6 +259,24 @@ Examples of how adding superclasses as Derived is useful [D] F a ~ beta Now we we get [D] beta ~ b, and can solve that. + -- Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + + When solving the superclasses of the (C (Maybe a) a) instance, we get + [G] C a b, and hance by superclasses, [G] G a, [G] L a b + [W] G (Maybe a) + Use the instance decl to get + [W] C a beta + Generate its derived superclass + [D] L a beta. Now using fundeps, combine with [G] L a b to get + [D] beta ~ b + which is what we want. + ---------- Historical note ----------- Example of why adding superclass of a Wanted as a Given would be terrible, see Note [Do not add superclasses of solved dictionaries] @@ -284,7 +297,7 @@ Then we'll use the instance decl to give [W] d4: Ord [a] ANd now we could bogusly solve d4 from d3. - +---------- End of historical note ----------- Note [Add superclasses only during canonicalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -322,36 +335,40 @@ newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS () -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored flavor cls xis | CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor - = do { let size = sizeTypes xis - loc' | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- Trac #10335 - | otherwise - = case ctLocOrigin loc of - GivenOrigin InstSkol - -> loc { ctl_origin = GivenOrigin (InstSC size) } - GivenOrigin (InstSC n) - -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } - _ -> loc - -- See Note [Solving superclass constraints] in TcInstDcls - -- for explantation of loc' - - ; given_evs <- newGivenEvVars loc' (mkEvScSelectors (EvId evar) cls xis) + = do { given_evs <- newGivenEvVars (mk_given_loc loc) + (mkEvScSelectors (EvId evar) cls xis) ; emitWorkNC given_evs } | isEmptyVarSet (tyVarsOfTypes xis) = return () -- Wanteds with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] - | otherwise -- Derived case, just add those SC that can lead to improvement. + | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis impr_theta = filter isImprovementPred sc_rec_theta loc = ctEvLoc flavor ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta ; emitNewDeriveds loc impr_theta } + where + size = sizeTypes xis + mk_given_loc loc + | isCTupleClass cls + = loc -- For tuple predicates, just take them apart, without + -- adding their (large) size into the chain. When we + -- get down to a base predicate, we'll include its size. + -- Trac #10335 + + | GivenOrigin skol_info <- ctLocOrigin loc + -- See Note [Solving superclass constraints] in TcInstDcls + -- for explantation of this transformation for givens + = case skol_info of + InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } + InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } + _ -> loc + + | otherwise -- Probably doesn't happen, since this function + = loc -- is only used for Givens, but does no harm {- ************************************************************************ diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index bc1bac291c..e868da2638 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -19,7 +19,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, import HsSyn import TcEnv -import TcPat( addInlinePrags, completeSigPolyId ) +import TcPat( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv ) import TcEvidence( idHsWrapper ) import TcBinds import TcUnify @@ -157,7 +157,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each ; let (tyvars, _, _, op_items) = classBigSig clas - prag_fn = mkPragFun sigs default_binds + prag_fn = mkPragEnv sigs default_binds sig_fn = mkHsSigFun sigs clas_tyvars = snd (tcSuperSkolTyVars tyvars) pred = mkClassPred clas (mkTyVarTys clas_tyvars) @@ -171,7 +171,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- with redundant constraints; but not for DefMeth, where -- the default method may well be 'error' or something NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) - (prag_fn (idName sel_id)) + (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } tc_dm = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn @@ -184,7 +184,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name - -> HsSigFun -> PragFun -> Id -> Name -> Bool + -> HsSigFun -> TcPragEnv -> Id -> Name -> Bool -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) @@ -250,8 +250,8 @@ tcDefMeth clas tyvars this_dict binds_in | otherwise = pprPanic "tcDefMeth" (ppr sel_id) where sel_name = idName sel_id - prags = prag_fn sel_name - no_prag_fn _ = [] -- No pragmas for local_meth_id; + prags = lookupPragEnv prag_fn sel_name + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; -- they are all for meth_id --------------- diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 7e5e75ccb4..8da2229067 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -1219,13 +1219,15 @@ sideConditions mtheta cls cond_args cls) | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond` cond_vanilla `andCond` - cond_functorOK True) + cond_functorOK True False) | cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond` cond_vanilla `andCond` - cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types + cond_functorOK False True) + -- Functor/Fold/Trav works ok + -- for rank-n types | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond` cond_vanilla `andCond` - cond_functorOK False) + cond_functorOK False False) | cls_key == genClassKey = Just (checkFlag Opt_DeriveGeneric `andCond` cond_vanilla `andCond` cond_RepresentableOk) @@ -1346,14 +1348,14 @@ cond_isProduct (_, rep_tc, _) functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] -cond_functorOK :: Bool -> Condition +cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class -- Currently: (a) at least one argument -- (b) don't use argument contravariantly -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) -- (d) optionally: don't use function types -- (e) no "stupid context" on data type -cond_functorOK allowFunctions (_, rep_tc, _) +cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) | null tc_tvs = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must have some type parameters")) @@ -1375,6 +1377,9 @@ cond_functorOK allowFunctions (_, rep_tc, _) check_universal :: DataCon -> Validity check_universal con + | allowExQuantifiedLastTyVar + = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] + -- in TcGenDeriv | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) , tv `elem` dataConUnivTyVars con , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con)) @@ -1442,7 +1447,7 @@ badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg {- Note [Check that the type variable is truly universal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Functor, Foldable, Traversable, we must check that the *last argument* +For Functor and Traversable instances, we must check that the *last argument* of the type constructor is used truly universally quantified. Example data T a b where @@ -1461,6 +1466,20 @@ Eg. for T1-T3 we can write fmap f (T2 b c) = T2 (f b) c fmap f (T3 x) = T3 (f x) +We need not perform these checks for Foldable instances, however, since +functions in Foldable can only consume existentially quantified type variables, +rather than produce them (as is the case in Functor and Traversable functions.) +As a result, T can have a derived Foldable instance: + + foldr f z (T1 a b) = f b z + foldr f z (T2 b c) = f b z + foldr f z (T3 x) = f x z + foldr f z (T4 x) = f x z + foldr f z (T5 x) = f x z + foldr _ z T6 = z + +See Note [DeriveFoldable with ExistentialQuantification] in TcGenDeriv. + Note [Superclasses of derived instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 25ffdfdb43..1a96c3e2fb 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -698,14 +698,15 @@ mkIrredErr ctxt cts ---------------- mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) - | isOutOfScopeCt ct + | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound + -- Suggest possible in-scope variables in the message = do { dflags <- getDynFlags ; rdr_env <- getGlobalRdrEnv ; mkLongErrAt (RealSrcSpan (tcl_loc lcl_env)) out_of_scope_msg (unknownNameSuggestions dflags rdr_env (tcl_rdr lcl_env) (mkRdrUnqual occ)) } - | otherwise + | otherwise -- Explicit holes, like "_" or "_f" = do { (ctxt, binds_doc, ct) <- relevantBindings False ctxt ct -- The 'False' means "don't filter the bindings"; see Trac #8191 ; mkErrorMsgFromCt ctxt ct (hole_msg $$ binds_doc) } @@ -824,7 +825,8 @@ mkEqErr1 ctxt ct = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs - ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct) + ; exp_syns <- goptM Opt_PrintExpandedSynonyms + ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct) exp_syns coercible_msg = case ctEqRel ct of NomEq -> empty ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 @@ -845,20 +847,23 @@ mkEqErr1 ctxt ct -- If the types in the error message are the same as the types -- we are unifying, don't add the extra expected/actual message - mk_wanted_extra orig@(TypeEqOrigin {}) - = mkExpectedActualMsg ty1 ty2 orig + mk_wanted_extra :: CtOrigin -> Bool -> (Maybe SwapFlag, SDoc) + mk_wanted_extra orig@(TypeEqOrigin {}) expandSyns + = mkExpectedActualMsg ty1 ty2 orig expandSyns - mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) + mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) expandSyns = (Nothing, msg1 $$ msg2) where msg1 = hang (ptext (sLit "When matching types")) 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) msg2 = case sub_o of - TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o) - _ -> empty + TypeEqOrigin {} -> + snd (mkExpectedActualMsg cty1 cty2 sub_o expandSyns) + _ -> + empty - mk_wanted_extra _ = (Nothing, empty) + mk_wanted_extra _ _ = (Nothing, empty) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint -- is left over. @@ -1201,17 +1206,169 @@ misMatchMsg ct oriented ty1 ty2 | null s2 = s1 | otherwise = s1 ++ (' ' : s2) -mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc) +mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Bool + -> (Maybe SwapFlag, SDoc) -- NotSwapped means (actual, expected), IsSwapped is the reverse -mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp }) +mkExpectedActualMsg ty1 ty2 + (TypeEqOrigin { uo_actual = act, uo_expected = exp }) printExpanded | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped, empty) | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty) | otherwise = (Nothing, msg) where - msg = vcat [ text "Expected type:" <+> ppr exp - , text " Actual type:" <+> ppr act ] + msg = vcat + [ text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act + , if printExpanded then expandedTys else empty + ] + + expandedTys = + ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr expTy1 + , text " Actual type:" <+> ppr expTy2 + ] + + (expTy1, expTy2) = expandSynonymsToMatch exp act + +mkExpectedActualMsg _ _ _ _ = panic "mkExpectedAcutalMsg" + +pickyEqType :: TcType -> TcType -> Bool +-- ^ Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +pickyEqType ty1 ty2 + = go init_env ty1 ty2 + where + init_env = + mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) + go env (TyVarTy tv1) (TyVarTy tv2) = + rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = + lit1 == lit2 + go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = + go env (tyVarKind tv1) (tyVarKind tv2) && go (rnBndr2 env tv1 tv2) t1 t2 + go env (AppTy s1 t1) (AppTy s2 t2) = + go env s1 s2 && go env t1 t2 + go env (FunTy s1 t1) (FunTy s2 t2) = + go env s1 s2 && go env t1 t2 + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = + (tc1 == tc2) && gos env ts1 ts2 + go _ _ _ = + False + + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False + +{- +Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. It should work like this: + +Given two types t1 and t2: + + * If they're already same, it shouldn't expand any type synonyms and + just return. -mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg" + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it should expand C1 and C2 if they're different type + synonyms. Then it should continue doing same thing on expanded types. If C1 + and C2 are same, then we should apply same procedure to arguments of C1 + and argument of C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is + `T (T5, T3, Bool)` where T5 = T4, T4 = T3, ..., T1 = X, we should return + `T (T3, T3, Int)` and `T (T3, T3, Bool)`. + +In the implementation, we just search in all possible solutions for a solution +that does minimum amount of expansions. This leads to a complex algorithm: If +we have two synonyms like X_m = X_{m-1} = .. X and Y_n = Y_{n-1} = .. Y, where +X and Y are rigid types, we expand m * n times. But in practice it's not a +problem because deeply nested synonyms with no intervening rigid type +constructors are vanishingly rare. + +-} + +-- | Expand type synonyms in given types only enough to make them as equal as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (_, ty1_ret, ty2_ret) = go 0 ty1 ty2 + + -- | Returns (number of synonym expansions done to make types similar, + -- type synonym expanded version of first type, + -- type synonym expanded version of second type) + -- + -- Int argument is number of synonym expansions done so far. + go :: Int -> Type -> Type -> (Int, Type, Type) + go exps t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (exps, t1, t2) + + go exps t1@(TyConApp tc1 tys1) t2@(TyConApp tc2 tys2) + | tc1 == tc2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. + let (exps', tys1', tys2') = unzip3 $ zipWith (go 0) tys1 tys2 + in (exps + sum exps', TyConApp tc1 tys1', TyConApp tc2 tys2') + | otherwise = + -- Try to expand type constructors + case (tcView t1, tcView t2) of + -- When only one of the constructors is a synonym, we just + -- expand it and continue search + (Just t1', Nothing) -> + go (exps + 1) t1' t2 + (Nothing, Just t2') -> + go (exps + 1) t1 t2' + (Just t1', Just t2') -> + -- Both constructors are synonyms, but they may be synonyms of + -- each other. We just search for minimally expanded solution. + -- See Note [Expanding type synonyms to make types similar]. + let sol1@(exp1, _, _) = go (exps + 1) t1' t2 + sol2@(exp2, _, _) = go (exps + 1) t1 t2' + in if exp1 < exp2 then sol1 else sol2 + (Nothing, Nothing) -> + -- None of the constructors are synonyms, nothing to do + (exps, t1, t2) + + go exps t1@TyConApp{} t2 + | Just t1' <- tcView t1 = go (exps + 1) t1' t2 + | otherwise = (exps, t1, t2) + + go exps t1 t2@TyConApp{} + | Just t2' <- tcView t2 = go (exps + 1) t1 t2' + | otherwise = (exps, t1, t2) + + go exps (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = + let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1 + (exps2, t1_2', t2_2') = go 0 t1_2 t2_2 + in (exps + exps1 + exps2, mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') + + go exps (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) = + let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1 + (exps2, t1_2', t2_2') = go 0 t1_2 t2_2 + in (exps + exps1 + exps2, FunTy t1_1' t1_2', FunTy t2_1' t2_2') + + go exps (ForAllTy tv1 t1) (ForAllTy tv2 t2) = + -- NOTE: We may have a bug here, but we just can't reproduce it easily. + -- See D1016 comments for details and our attempts at producing a test + -- case. + let (exps1, t1', t2') = go exps t1 t2 + in (exps1, ForAllTy tv1 t1', ForAllTy tv2 t2') + + go exps t1 t2 = (exps, t1, t2) sameOccExtra :: TcType -> TcType -> SDoc -- See Note [Disambiguating (X ~ X) errors] @@ -1363,6 +1520,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) givens = getUserGivens ctxt all_tyvars = all isTyVarTy tys + cannot_resolve_msg :: Ct -> SDoc -> SDoc cannot_resolve_msg ct binds_msg = vcat [ addArising orig no_inst_msg , nest 2 extra_note diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index c8de8a5a31..800d47836c 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -910,25 +910,22 @@ People write so much, where runST :: (forall s. ST s a) -> a that I have finally given in and written a special type-checking -rule just for saturated appliations of ($). +rule just for saturated appliations of ($).\ Note [Typing rule for seq] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to allow x `seq` (# p,q #) which suggests this type for seq: - seq :: forall (a:*) (b:??). a -> b -> b, -with (b:??) meaning that be can be instantiated with an unboxed tuple. -But that's ill-kinded! Function arguments can't be unboxed tuples. -And indeed, you could not expect to do this with a partially-applied -'seq'; it's only going to work when it's fully applied. so it turns -into + seq :: forall (a:*) (b:Open). a -> b -> b, +with (b:Open) meaning that be can be instantiated with an unboxed +tuple. The trouble is that this might accept a partially-applied +'seq', and I'm just not certain that would work. I'm only sure it's +only going to work when it's fully applied, so it turns into case x of _ -> (# p,q #) -For a while I slid by by giving 'seq' an ill-kinded type, but then -the simplifier eta-reduced an application of seq and Lint blew up -with a kind error. It seems more uniform to treat 'seq' as it it -was a language construct. +So it seems more uniform to treat 'seq' as it it was a language +construct. See Note [seqId magic] in MkId, and -} @@ -1273,6 +1270,7 @@ tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name -> TcRhoType -> TcM TcAppResult -- (seq e1 e2) :: res_ty -- We need a special typing rule because res_ty can be unboxed +-- See Note [Typing rule for seq] tcSeq loc fun_name arg1 arg2 res_ty = do { fun <- tcLookupId fun_name ; (arg1', arg1_ty) <- tcInfer (tcPolyMonoExpr arg1) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index d30c1ca3b1..4a1ce4f815 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1673,12 +1673,20 @@ deepSubtypesContaining tv foldDataConArgs :: FFoldType a -> DataCon -> [a] -- Fold over the arguments of the datacon foldDataConArgs ft con - = map (functorLikeTraverse tv ft) (dataConOrigArgTys con) + = map foldArg (dataConOrigArgTys con) where - Just tv = getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) - -- Argument to derive for, 'a in the above description - -- The validity and kind checks have ensured that - -- the Just will match and a::* + foldArg + = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of + Just tv -> functorLikeTraverse tv ft + Nothing -> const (ft_triv ft) + -- If we are deriving Foldable for a GADT, there is a chance that the last + -- type variable in the data type isn't actually a type variable at all. + -- (for example, this can happen if the last type variable is refined to + -- be a concrete type such as Int). If the last type variable is refined + -- to be a specific type, then getTyVar_maybe will return Nothing. + -- See Note [DeriveFoldable with ExistentialQuantification] + -- + -- The kind checks have ensured the last type parameter is of kind *. -- Make a HsLam using a fresh variable from a State monad mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) @@ -1747,6 +1755,24 @@ The cases are: Note that the arguments to the real foldr function are the wrong way around, since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). + +Foldable instances differ from Functor and Traversable instances in that +Foldable instances can be derived for data types in which the last type +variable is existentially quantified. In particular, if the last type variable +is refined to a more specific type in a GADT: + + data GADT a where + G :: a ~ Int => a -> G Int + +then the deriving machinery does not attempt to check that the type a contains +Int, since it is not syntactically equal to a type variable. That is, the +derived Foldable instance for GADT is: + + instance Foldable GADT where + foldr _ z (GADT _) = z + +See Note [DeriveFoldable with ExistentialQuantification]. + -} gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) @@ -2305,4 +2331,80 @@ OccName we generate for the new binding. In the past we used mkDerivedRdrName name occ_fun, which made an original name But: (a) that does not work well for standalone-deriving either (b) an unqualified name is just fine, provided it can't clash with user code + +Note [DeriveFoldable with ExistentialQuantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Traversable instances can only be derived for data types whose +last type parameter is truly universally polymorphic. For example: + + data T a b where + T1 :: b -> T a b -- YES, b is unconstrained + T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) + T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) + T4 :: Int -> T a Int -- NO, this is just like T3 + T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even + -- though a is existential + T6 :: Int -> T Int b -- YES, b is unconstrained + +For Foldable instances, however, we can completely lift the constraint that +the last type parameter be truly universally polymorphic. This means that T +(as defined above) can have a derived Foldable instance: + + instance Foldable (T a) where + foldr f z (T1 b) = f b z + foldr f z (T2 b) = f b z + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + foldr f z (T5 a b) = f b z + foldr f z (T6 a) = z + + foldMap f (T1 b) = f b + foldMap f (T2 b) = f b + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + foldMap f (T5 a b) = f b + foldMap f (T6 a) = mempty + +In a Foldable instance, it is safe to fold over an occurrence of the last type +parameter that is not truly universally polymorphic. However, there is a bit +of subtlety in determining what is actually an occurrence of a type parameter. +T3 and T4, as defined above, provide one example: + + data T a b where + ... + T3 :: b ~ Int => b -> T a b + T4 :: Int -> T a Int + ... + + instance Foldable (T a) where + ... + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + ... + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + ... + +Notice that the argument of T3 is folded over, whereas the argument of T4 is +not. This is because we only fold over constructor arguments that +syntactically mention the universally quantified type parameter of that +particular data constructor. See foldDataConArgs for how this is implemented. + +As another example, consider the following data type. The argument of each +constructor has the same type as the last type parameter: + + data E a where + E1 :: (a ~ Int) => a -> E a + E2 :: Int -> E Int + E3 :: (a ~ Int) => a -> E Int + E4 :: (a ~ Int) => Int -> E a + +Only E1's argument is an occurrence of a universally quantified type variable +that is syntactically equivalent to the last type parameter, so only E1's +argument will be be folded over in a derived Foldable instance. + +See Trac #10447 for the original discussion on this feature. Also see +https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor +for a more in-depth explanation. + -} diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 5a93f20116..c5765a5457 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -18,7 +18,7 @@ import TcTyClsDecls import TcClassDcl( tcClassDecl2, HsSigFun, lookupHsSig, mkHsSigFun, findMethodBind, instantiateMethod ) -import TcPat ( addInlinePrags, completeSigPolyId ) +import TcPat ( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv ) import TcRnMonad import TcValidity import TcMType @@ -1244,7 +1244,7 @@ tcMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds - -> ([Located TcSpecPrag], PragFun) + -> ([Located TcSpecPrag], TcPragEnv) -> [(Id, DefMeth)] -> InstBindings Name -> TcM ([Id], LHsBinds Id, Bag Implication) @@ -1363,7 +1363,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds -> Bool -> HsSigFun - -> ([LTcSpecPrag], PragFun) + -> ([LTcSpecPrag], TcPragEnv) -> Id -> LHsBind Name -> SrcSpan -> TcM (TcId, LHsBind Id, Maybe Implication) tcMethodBody clas tyvars dfun_ev_vars inst_tys @@ -1377,7 +1377,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id - ; let prags = prag_fn (idName sel_id) + ; let prags = lookupPragEnv prag_fn (idName sel_id) -- A method always has a complete type signature, hence -- it is safe to call completeSigPolyId local_meth_id = completeSigPolyId local_meth_sig @@ -1414,7 +1414,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing | otherwise = thing - no_prag_fn _ = [] -- No pragmas for local_meth_id; + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; -- they are all for meth_id @@ -1739,12 +1739,12 @@ Note that -} tcSpecInstPrags :: DFunId -> InstBindings Name - -> TcM ([Located TcSpecPrag], PragFun) + -> TcM ([Located TcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags -- The filter removes the pragmas for methods - ; return (spec_inst_prags, mkPragFun uprags binds) } + ; return (spec_inst_prags, mkPragEnv uprags binds) } ------------------------------ tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index efc28de36d..733f1e8afb 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -1535,49 +1535,6 @@ Then it is solvable, but its very hard to detect this on the spot. It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. -Note [When improvement happens during solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During solving we maintain at "model" in the InertCans -Improvement for functional dependencies or type-function injectivity -means emitting a Derived equality constraint by interacting the work -item with an inert item, or with the top-level instances. e.g. - - class C a b | a -> b - [W] C a b, [W] C a c ==> [D] b ~ c - -We fire the fundep improvement if the "work item" is Given or Derived, -but not Wanted. Reason: - - * Given: we want to spot Given/Given inconsistencies because that means - unreachable code. See typecheck/should_fail/FDsFromGivens - - * Derived: during the improvement phase (i.e. when handling Derived - constraints) we also do improvement for functional dependencies. e.g. - And similarly wrt top-level instances. - - * Wanted: spotting fundep improvements is somewhat inefficient, and - and if we can solve without improvement so much the better. - So we don't bother to do this when solving Wanteds, instead - leaving it for the try_improvement loop - -Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - -When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hance by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) -Use the instance decl to get - [W] C a beta - -During improvement (see Note [The improvement story]) we generate the superclasses -of (C a beta): [D] L a beta. Now using fundeps, combine with [G] L a b to get -[D] beta ~ b, which is what we want. - Note [Weird fundeps] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index f8d23a48c4..3c521cf27a 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -8,11 +8,12 @@ TcPat: Typechecking patterns {-# LANGUAGE CPP, RankNTypes #-} -module TcPat ( tcLetPat, TcSigFun, TcPragFun +module TcPat ( tcLetPat, TcSigFun + , TcPragEnv, lookupPragEnv, emptyPragEnv , TcSigInfo(..), TcPatSynInfo(..) , findScopedTyVars, isPartialSig , completeSigPolyId, completeSigPolyId_maybe - , LetBndrSpec(..), addInlinePrags, warnPrags + , LetBndrSpec(..), addInlinePrags , tcPat, tcPats, newNoSigLetBndr , addDataConStupidTheta, badFieldCon, polyPatSig ) where @@ -28,6 +29,7 @@ import Id import Var import Name import NameSet +import NameEnv import TcEnv import TcMType import TcValidity( arityErr ) @@ -47,7 +49,9 @@ import SrcLoc import Util import Outputable import FastString +import Maybes( orElse ) import Control.Monad + {- ************************************************************************ * * @@ -119,7 +123,7 @@ data LetBndrSpec = LetLclBndr -- The binder is just a local one; -- an AbsBinds will provide the global version - | LetGblBndr TcPragFun -- Generalisation plan is NoGen, so there isn't going + | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going -- to be an AbsBinds; So we must bind the global version -- of the binder right away. -- Oh, and here is the inline-pragma information @@ -132,9 +136,15 @@ inPatBind (PE { pe_ctxt = LetPat {} }) = True inPatBind (PE { pe_ctxt = LamPat {} }) = False --------------- -type TcPragFun = Name -> [LSig Name] +type TcPragEnv = NameEnv [LSig Name] type TcSigFun = Name -> Maybe TcSigInfo +emptyPragEnv :: TcPragEnv +emptyPragEnv = emptyNameEnv + +lookupPragEnv :: TcPragEnv -> Name -> [LSig Name] +lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] + data TcSigInfo = TcSigInfo { sig_name :: Name, -- The binder name of the type signature. When @@ -327,7 +337,7 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty | LetGblBndr prags <- no_gen , Just sig <- lookup_sig bndr_name , Just poly_id <- sig_poly_id sig - = do { bndr_id <- addInlinePrags poly_id (prags bndr_name) + = do { bndr_id <- addInlinePrags poly_id (lookupPragEnv prags bndr_name) ; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id)) ; co <- unifyPatType (idType bndr_id) pat_ty ; return (co, bndr_id) } @@ -351,31 +361,35 @@ newNoSigLetBndr LetLclBndr name ty =do { mono_name <- newLocalName name ; return (mkLocalId mono_name ty) } newNoSigLetBndr (LetGblBndr prags) name ty - = addInlinePrags (mkLocalId name ty) (prags name) + = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) ---------- addInlinePrags :: TcId -> [LSig Name] -> TcM TcId addInlinePrags poly_id prags - = do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags) - ; tc_inl inl_sigs } - where - inl_sigs = filter isInlineLSig prags - tc_inl [] = return poly_id - tc_inl (L loc (InlineSig _ prag) : other_inls) - = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) - ; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) - ; return (poly_id `setInlinePragma` prag) } - tc_inl _ = panic "tc_inl" - - warn_dup_inline = warnPrags poly_id inl_sigs $ - ptext (sLit "Duplicate INLINE pragmas for") - -warnPrags :: Id -> [LSig Name] -> SDoc -> TcM () -warnPrags id bad_sigs herald - = addWarnTc (hang (herald <+> quotes (ppr id)) - 2 (ppr_sigs bad_sigs)) + | inl@(L _ prag) : inls <- inl_prags + = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) + ; unless (null inls) (warn_multiple_inlines inl inls) + ; return (poly_id `setInlinePragma` prag) } + | otherwise + = return poly_id where - ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) + inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags] + + warn_multiple_inlines _ [] = return () + + warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) + | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 + , isEmptyInlineSpec (inlinePragmaSpec prag1) + = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop + -- and inl2 is a user NOINLINE pragma; we don't want to complain + warn_multiple_inlines inl2 inls + | otherwise + = setSrcSpan loc $ + addWarnTc (hang (ptext (sLit "Multiple INLINE pragmas for") <+> ppr poly_id) + 2 (vcat (ptext (sLit "Ignoring all but the first") + : map pp_inl (inl1:inl2:inls)))) + + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) {- Note [Typing patterns in pattern bindings] diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index dc470b4a38..eb2872bfdc 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -372,7 +372,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat ; sig <- instTcTySigFromId builder_id -- See Note [Redundant constraints for builder] - ; (builder_binds, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) + ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } where diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 39f58148c5..fd4ea4fd8e 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -252,7 +252,7 @@ checkHsigIface' gr -- In general, for hsig files we can't assume that the implementing -- file actually implemented the instances (they may be reexported - -- from elsewhere. Where should we look for the instances? We do + -- from elsewhere). Where should we look for the instances? We do -- the same as we would otherwise: consult the EPS. This isn't -- perfect (we might conclude the module exports an instance -- when it doesn't, see #9422), but we will never refuse to compile @@ -280,10 +280,22 @@ tcRnModuleTcRnM hsc_env hsc_src }) (this_mod, prel_imp_loc) = setSrcSpan loc $ - do { let { dflags = hsc_dflags hsc_env } ; + do { let { dflags = hsc_dflags hsc_env + ; explicit_mod_hdr = isJust maybe_mod } ; tcg_env <- tcRnSignature dflags hsc_src ; - setGblEnv tcg_env { tcg_mod_name=maybe_mod } $ do { + setGblEnv tcg_env $ do { + + -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_info <- tcHiBootIface hsc_src this_mod ; + setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do { -- Deal with imports; first add implicit prelude implicit_prelude <- xoptM Opt_ImplicitPrelude; @@ -306,28 +318,18 @@ tcRnModuleTcRnM hsc_env hsc_src setGblEnv tcg_env1 $ do { - -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - -- - -- Do this *after* tcRnImports, so that we know whether - -- a module that we import imports us; and hence whether to - -- look for a hi-boot file - boot_iface <- tcHiBootIface hsc_src this_mod ; - -- Rename and type check the declarations traceRn (text "rn1a") ; tcg_env <- if isHsBootOrSig hsc_src then tcRnHsBootDecls hsc_src local_decls else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls boot_iface export_ies local_decls ; + tcRnSrcDecls explicit_mod_hdr export_ies local_decls ; setGblEnv tcg_env $ do { -- Process the export list traceRn (text "rn4a: before exports"); - tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; + tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ; traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) @@ -335,7 +337,7 @@ tcRnModuleTcRnM hsc_env hsc_src -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_iface ; + tcg_env <- checkHiBootIface tcg_env boot_info ; -- Compare the hsig tcg_env with the real thing checkHsigIface hsc_env tcg_env ; @@ -371,7 +373,7 @@ tcRnModuleTcRnM hsc_env hsc_src -- Dump output and return tcDump tcg_env ; return tcg_env - }}}} + }}}}} implicitPreludeWarn :: SDoc implicitPreludeWarn @@ -455,20 +457,31 @@ tcRnImports hsc_env import_decls ************************************************************************ -} -tcRnSrcDecls :: ModDetails +tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all -> Maybe (Located [LIE RdrName]) -- Exports -> [LHsDecl RdrName] -- Declarations -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings -tcRnSrcDecls boot_iface exports decls +tcRnSrcDecls explicit_mod_hdr exports decls = do { -- Do all the declarations - ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; - ; traceTc "Tc8" empty ; - ; setEnvs (tcg_env, tcl_env) $ - do { + ((tcg_env, tcl_env), lie) <- captureConstraints $ + do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ; + ; tcg_env <- setEnvs (tcg_env, tcl_env) $ + checkMain explicit_mod_hdr + ; return (tcg_env, tcl_env) } + ; setEnvs (tcg_env, tcl_env) $ do { + +#ifdef GHCI + -- Run all module finalizers + let th_modfinalizers_var = tcg_th_modfinalizers tcg_env + ; modfinalizers <- readTcRef th_modfinalizers_var + ; writeTcRef th_modfinalizers_var [] + ; mapM_ runQuasi modfinalizers +#endif /* GHCI */ + -- wanted constraints from static forms - stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ; + ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef -- Finish simplifying class constraints -- @@ -484,18 +497,18 @@ tcRnSrcDecls boot_iface exports decls -- * the global env exposes the instances to simplifyTop -- * the local env exposes the local Ids to simplifyTop, -- so that we get better error messages (monomorphism restriction) - new_ev_binds <- {-# SCC "simplifyTop" #-} - simplifyTop (andWC stWC lie) ; - traceTc "Tc9" empty ; + ; new_ev_binds <- {-# SCC "simplifyTop" #-} + simplifyTop (andWC stWC lie) + ; traceTc "Tc9" empty - failIfErrsM ; -- Don't zonk if there have been errors + ; failIfErrsM -- Don't zonk if there have been errors -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - let { TcGblEnv { tcg_type_env = type_env, + ; let { TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_sigs = sig_ns, tcg_ev_binds = cur_ev_binds, @@ -505,12 +518,12 @@ tcRnSrcDecls boot_iface exports decls tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- {-# SCC "zonkTopDecls" #-} zonkTopDecls all_ev_binds binds exports sig_ns rules vects imp_specs fords ; - let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', @@ -518,28 +531,21 @@ tcRnSrcDecls boot_iface exports decls tcg_vects = vects', tcg_fords = fords' } } ; - setGlobalTypeEnv tcg_env' final_type_env + ; setGlobalTypeEnv tcg_env' final_type_env } } -tc_rn_src_decls :: ModDetails - -> [LHsDecl RdrName] +tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module -tc_rn_src_decls boot_details ds +tc_rn_src_decls ds = {-# SCC "tc_rn_src_decls" #-} do { (first_group, group_tail) <- findSplice ds -- If ds is [] we get ([], Nothing) - -- The extra_deps are needed while renaming type and class declarations - -- See Note [Extra dependencies from .hs-boot files] in RnSource - ; let { tycons = typeEnvTyCons (md_types boot_details) - ; extra_deps | null tycons = Nothing - | otherwise = Just (mkFVs (map tyConName tycons)) } - -- Deal with decls up to, but not including, the first splice - ; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group + ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group -- rnTopSrcDecls fails if there are any errors #ifdef GHCI @@ -562,7 +568,7 @@ tc_rn_src_decls boot_details ds -- Rename TH-generated top-level declarations ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $ - rnTopSrcDecls extra_deps th_group + rnTopSrcDecls th_group -- Dump generated top-level declarations ; let msg = "top-level declarations added with addTopDecls" @@ -577,21 +583,12 @@ tc_rn_src_decls boot_details ds -- Type check all declarations ; (tcg_env, tcl_env) <- setGblEnv tcg_env $ - tcTopSrcDecls boot_details rn_decls + tcTopSrcDecls rn_decls -- If there is no splice, we're nearly done ; setEnvs (tcg_env, tcl_env) $ case group_tail of - { Nothing -> do { tcg_env <- checkMain -- Check for `main' -#ifdef GHCI - -- Run all module finalizers - ; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - ; modfinalizers <- readTcRef th_modfinalizers_var - ; writeTcRef th_modfinalizers_var [] - ; mapM_ runQuasi modfinalizers -#endif /* GHCI */ - ; return (tcg_env, tcl_env) - } + { Nothing -> return (tcg_env, tcl_env) #ifndef GHCI -- There shouldn't be a splice @@ -606,7 +603,7 @@ tc_rn_src_decls boot_details ds -- Glue them on the front of the remaining decls and loop ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) + tc_rn_src_decls (spliced_decls ++ rest_ds) } } #endif /* GHCI */ @@ -635,7 +632,7 @@ tcRnHsBootDecls hsc_src decls hs_ruleds = rule_decls, hs_vects = vect_decls, hs_annds = _, - hs_valds = val_binds }) <- rnTopSrcDecls Nothing first_group + hs_valds = val_binds }) <- rnTopSrcDecls first_group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { @@ -653,7 +650,7 @@ tcRnHsBootDecls hsc_src decls -- Typecheck type/class/isntance decls ; traceTc "Tc2 (boot)" empty ; (tcg_env, inst_infos, _deriv_binds) - <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls + <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -696,22 +693,24 @@ Once we've typechecked the body of the module, we want to compare what we've found (gathered in a TypeEnv) with the hi-boot details (if any). -} -checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv +checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv -- Compare the hi-boot file for this module (if there is one) -- with the type environment we've just come up with -- In the common case where there is no hi-boot file, the list -- of boot_names is empty. -checkHiBootIface - tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds - , tcg_insts = local_insts - , tcg_type_env = local_type_env - , tcg_exports = local_exports }) - boot_details - | HsBootFile <- hs_src -- Current module is already a hs-boot file! +checkHiBootIface tcg_env boot_info + | NoSelfBoot <- boot_info -- Common case = return tcg_env - | otherwise + | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! + = return tcg_env + + | SelfBoot { sb_mds = boot_details } <- boot_info + , TcGblEnv { tcg_binds = binds + , tcg_insts = local_insts + , tcg_type_env = local_type_env + , tcg_exports = local_exports } <- tcg_env = do { dfun_prs <- checkHiBootIface' local_insts local_type_env local_exports boot_details ; let boot_dfuns = map fst dfun_prs @@ -726,6 +725,8 @@ checkHiBootIface -- mentioning one of the dfuns from the boot module, then it -- can "see" that boot dfun. See Trac #4003 + | otherwise = panic "checkHiBootIface: unreachable code" + checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Id, Id)] -- Variant which doesn't require a full TcGblEnv; you could get the @@ -1087,12 +1088,12 @@ instMisMatch is_boot inst ************************************************************************ -} -rnTopSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) -- Fails if there are any errors -rnTopSrcDecls extra_deps group +rnTopSrcDecls group = do { -- Rename the source decls traceTc "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; traceTc "rn13" empty ; -- save the renamed syntax, if we want it @@ -1108,17 +1109,16 @@ rnTopSrcDecls extra_deps group return (tcg_env', rn_decls) } -tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_details - (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_valds = val_binds }) +tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc "Tc2 (src)" empty ; @@ -1127,7 +1127,7 @@ tcTopSrcDecls boot_details -- and import the supporting declarations traceTc "Tc3" empty ; (tcg_env, inst_infos, deriv_binds) - <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ; + <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { @@ -1213,8 +1213,7 @@ tcTopSrcDecls boot_details | otherwise = greUsedRdrName gre : rdrs --------------------------- -tcTyClsInstDecls :: ModDetails - -> [TyClGroup Name] +tcTyClsInstDecls :: [TyClGroup Name] -> [LInstDecl Name] -> [LDerivDecl Name] -> TcM (TcGblEnv, -- The full inst env @@ -1222,11 +1221,11 @@ tcTyClsInstDecls :: ModDetails -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances -tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls +tcTyClsInstDecls tycl_decls inst_decls deriv_decls = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE) | lid <- inst_decls, con <- get_cons lid ] $ -- Note [AFamDataCon: not promoting data family constructors] - do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + do { tcg_env <- tcTyAndClassDecls tycl_decls ; ; setGblEnv tcg_env $ tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls } where @@ -1268,16 +1267,16 @@ type checking 'S' we'll produce a decent error message. ************************************************************************ -} -checkMain :: TcM TcGblEnv +checkMain :: Bool -- False => no 'module M(..) where' header at all + -> TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. -checkMain - = do { tcg_env <- getGblEnv ; - dflags <- getDynFlags ; - check_main dflags tcg_env - } +checkMain explicit_mod_hdr + = do { dflags <- getDynFlags + ; tcg_env <- getGblEnv + ; check_main dflags tcg_env explicit_mod_hdr } -check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv -check_main dflags tcg_env +check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv +check_main dflags tcg_env explicit_mod_hdr | mod /= main_mod = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> return tcg_env @@ -1323,13 +1322,12 @@ check_main dflags tcg_env }) }}} where - mod = tcg_mod tcg_env - main_mod = mainModIs dflags - main_fn = getMainFun dflags - interactive = ghcLink dflags == LinkInMemory - implicit_mod = isNothing (tcg_mod_name tcg_env) + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_fn = getMainFun dflags + interactive = ghcLink dflags == LinkInMemory - complain_no_main = checkTc (interactive && implicit_mod) noMainMsg + complain_no_main = checkTc (interactive && not explicit_mod_hdr) noMainMsg -- In interactive mode, without an explicit module header, don't -- worry about the absence of 'main'. -- In other modes, fail altogether, so that we don't go on @@ -1402,8 +1400,9 @@ runTcInteractive hsc_env thing_inside vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] - ; let getOrphans m = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) + + ; let getOrphans m = fmap (concatMap (\iface -> mi_module iface + : dep_orphs (mi_deps iface))) (loadSrcInterface (text "runTcInteractive") m False Nothing) ; orphs <- fmap concat . forM (ic_imports icxt) $ \i -> @@ -1908,8 +1907,8 @@ tcRnDeclsi :: HscEnv tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ do - ((tcg_env, tclcl_env), lie) <- - captureConstraints $ tc_rn_src_decls emptyModDetails local_decls + ((tcg_env, tclcl_env), lie) <- captureConstraints $ + tc_rn_src_decls local_decls setEnvs (tcg_env, tclcl_env) $ do -- wanted constraints from static forms diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 0e44c4ca78..c1392f483a 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -120,7 +120,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_mod = mod, tcg_src = hsc_src, tcg_sig_of = getSigOf dflags (moduleName mod), - tcg_mod_name = Nothing, tcg_impl_rdr_env = Nothing, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, @@ -162,6 +161,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_doc_hdr = Nothing, tcg_hpc = False, tcg_main = Nothing, + tcg_self_boot = NoSelfBoot, tcg_safeInfer = infer_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], @@ -611,6 +611,9 @@ getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC h tcIsHsBootOrSig :: TcRn Bool tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } +tcSelfBootInfo :: TcRn SelfBootInfo +tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } + getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 31b651e5e0..7f8fec6156 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -36,6 +36,7 @@ module TcRnTypes( -- Typechecker types TcTypeEnv, TcIdBinderStack, TcIdBinder(..), TcTyThing(..), PromotionErr(..), TcIdFlavor(..), + SelfBootInfo(..), pprTcTyThingCategory, pprPECategory, -- Desugaring types @@ -337,8 +338,6 @@ data TcGblEnv -- ^ What kind of module (regular Haskell, hs-boot, hsig) tcg_sig_of :: Maybe Module, -- ^ Are we being compiled as a signature of an implementation? - tcg_mod_name :: Maybe (Located ModuleName), - -- ^ @Nothing@: \"module X where\" is omitted tcg_impl_rdr_env :: Maybe GlobalRdrEnv, -- ^ Environment used only during -sig-of for resolving top level -- bindings. See Note [Signature parameters in TcGblEnv and DynFlags] @@ -477,6 +476,9 @@ data TcGblEnv tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the -- prog uses hpc instrumentation. + tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a + -- corresponding hi-boot file + tcg_main :: Maybe Name, -- ^ The Name of the main -- function, if this module is -- the main module. @@ -560,6 +562,15 @@ data RecFieldEnv -- module. For imported modules, we get the same info from the -- TypeEnv +data SelfBootInfo + = NoSelfBoot -- No corresponding hi-boot file + | SelfBoot + { sb_mds :: ModDetails -- There was a hi-boot file, + , sb_tcs :: NameSet -- defining these TyCons, + , sb_ids :: NameSet } -- and these Ids + -- We need this info to compute a safe approximation to + -- recursive loops, to avoid infinite inlinings + {- Note [Tracking unused binding and imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 766c1d4ce1..555f9ed7a2 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -91,7 +91,6 @@ import DsMonad import Serialized import ErrUtils import Util -import Data.List ( mapAccumL ) import Unique import VarSet ( isEmptyVarSet ) import Data.Maybe @@ -1136,16 +1135,12 @@ reifyTyCon tc reifyDataCon :: [Type] -> DataCon -> TcM TH.Con -- For GADTs etc, see Note [Reifying data constructors] reifyDataCon tys dc - = do { let (tvs, theta, arg_tys, _) = dataConSig dc - subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs - (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs) - theta' = substTheta subst' theta - arg_tys' = substTys subst' arg_tys + = do { let (ex_tvs, theta, arg_tys) = dataConInstSig dc tys stricts = map reifyStrict (dataConSrcBangs dc) fields = dataConFieldLabels dc name = reifyName dc - ; r_arg_tys <- reifyTypes arg_tys' + ; r_arg_tys <- reifyTypes arg_tys ; let main_con | not (null fields) = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys) @@ -1158,12 +1153,12 @@ reifyDataCon tys dc [s1, s2] = stricts ; ASSERT( length arg_tys == length stricts ) - if null ex_tvs' && null theta then + if null ex_tvs && null theta then return main_con else do - { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' - ; return (TH.ForallC ex_tvs'' cxt main_con) } } + { cxt <- reifyCxt theta + ; ex_tvs' <- reifyTyVars ex_tvs + ; return (TH.ForallC ex_tvs' cxt main_con) } } ------------------------------ reifyClass :: Class -> TcM TH.Info diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index ca20ee979c..f58178a735 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -107,12 +107,11 @@ Thus, we take two passes over the resulting tycons, first checking for general validity and then checking for valid role annotations. -} -tcTyAndClassDecls :: ModDetails - -> [TyClGroup Name] -- Mutually-recursive groups in dependency order +tcTyAndClassDecls :: [TyClGroup Name] -- Mutually-recursive groups in dependency order -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons -- Fails if there are any errors -tcTyAndClassDecls boot_details tyclds_s +tcTyAndClassDecls tyclds_s = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade fold_env tyclds_s -- Type check each group in dependency order folding the global env @@ -120,13 +119,13 @@ tcTyAndClassDecls boot_details tyclds_s fold_env :: [TyClGroup Name] -> TcM TcGblEnv fold_env [] = getGblEnv fold_env (tyclds:tyclds_s) - = do { tcg_env <- tcTyClGroup boot_details tyclds + = do { tcg_env <- tcTyClGroup tyclds ; setGblEnv tcg_env $ fold_env tyclds_s } -- remaining groups are typecheck in the extended global env -tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv +tcTyClGroup :: TyClGroup Name -> TcM TcGblEnv -- Typecheck one strongly-connected component of type and class decls -tcTyClGroup boot_details tyclds +tcTyClGroup tyclds = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class -- See Note [Kind checking for type and class decls] @@ -138,8 +137,9 @@ tcTyClGroup boot_details tyclds ; let role_annots = extractRoleAnnots tyclds decls = group_tyclds tyclds ; tyclss <- fixM $ \ rec_tyclss -> do - { is_boot <- tcIsHsBootOrSig - ; let rec_flags = calcRecFlags boot_details is_boot + { is_boot <- tcIsHsBootOrSig + ; self_boot <- tcSelfBootInfo + ; let rec_flags = calcRecFlags self_boot is_boot role_annots rec_tyclss -- Populate environment with knot-tied ATyCon for TyCons diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 6787c9c798..827f21793c 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -24,7 +24,7 @@ import HsSyn import Class import Type import Kind -import HscTypes +import TcRnTypes( SelfBootInfo(..) ) import TyCon import DataCon import Var @@ -34,7 +34,6 @@ import VarEnv import VarSet import NameSet import Coercion ( ltRole ) -import Avail import Digraph import BasicTypes import SrcLoc @@ -359,7 +358,7 @@ data RecTyInfo = RTI { rti_promotable :: Bool , rti_roles :: Name -> [Role] , rti_is_rec :: Name -> RecFlag } -calcRecFlags :: ModDetails -> Bool -- hs-boot file? +calcRecFlags :: SelfBootInfo -> Bool -- hs-boot file? -> RoleAnnots -> [TyThing] -> RecTyInfo -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module. -- Any type constructors in boot_names are automatically considered loop breakers @@ -381,7 +380,9 @@ calcRecFlags boot_details is_boot mrole_env tyclss is_rec n | n `elemNameSet` rec_names = Recursive | otherwise = NonRecursive - boot_name_set = availsToNameSet (md_exports boot_details) + boot_name_set = case boot_details of + NoSelfBoot -> emptyNameSet + SelfBoot { sb_tcs = tcs } -> tcs rec_names = boot_name_set `unionNameSet` nt_loop_breakers `unionNameSet` prod_loop_breakers diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 2866e32591..f29b36fa12 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -64,7 +64,7 @@ module TcType ( -- Predicates. -- Again, newtypes are opaque eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, - pickyEqType, tcEqType, tcEqKind, + tcEqType, tcEqKind, isSigmaTy, isRhoTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, @@ -1143,26 +1143,6 @@ tcEqType ty1 ty2 gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 gos _ _ _ = False -pickyEqType :: TcType -> TcType -> Bool --- Check when two types _look_ the same, _including_ synonyms. --- So (pickyEqType String [Char]) returns False -pickyEqType ty1 ty2 - = go init_env ty1 ty2 - where - init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) - go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 - go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 - go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2) - && go (rnBndr2 env tv1 tv2) t1 t2 - go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 - go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 - go _ _ _ = False - - gos _ [] [] = True - gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 - gos _ _ _ = False - {- Note [Occurs check expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index e24fe00e79..dc1546c146 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -31,7 +31,7 @@ module InstEnv ( #include "HsVersions.h" -import CoreSyn (IsOrphan(..), isOrphan, notOrphan) +import CoreSyn ( IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor ) import Module import Class import Var @@ -236,12 +236,9 @@ mkLocalInstance dfun oflag tvs cls tys mb_ns | null fds = [choose_one arg_names] | otherwise = map do_one fds do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names - , not (tv `elem` rtvs)] + , not (tv `elem` rtvs)] - choose_one :: [NameSet] -> IsOrphan - choose_one nss = case nameSetElems (unionNameSets nss) of - [] -> IsOrphan - (n : _) -> NotOrphan (nameOccName n) + choose_one nss = chooseOrphanAnchor (nameSetElems (unionNameSets nss)) mkImportedInstance :: Name -> [Maybe Name] @@ -272,8 +269,12 @@ instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot -- possibly be instantiated to actual, nor vice versa; -- False is non-committal -instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as -instanceCantMatch _ _ = False -- Safe +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: Maybe Name -> Maybe Name -> Bool +itemCantMatch (Just t) (Just a) = t /= a +itemCantMatch _ _ = False {- Note [When exactly is an instance decl an orphan?] diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index e3574ee2c8..57a43ff3ea 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -6,7 +6,7 @@ module Unify ( -- Matching of types: -- the "tc" prefix indicates that matching always -- respects newtypes (rather than looking through them) - tcMatchTy, tcMatchTys, tcMatchTyX, + tcMatchTy, tcMatchTys, tcMatchTyX, tcMatchTysX, ruleMatchTyX, tcMatchPreds, MatchResult, MatchResult'(..), @@ -103,17 +103,11 @@ tcMatchTy :: TyVarSet -- Template tyvars -> Type -- Target -> Maybe (MatchResult l) -- One-shot; in principle the template -- variables could be free in the target - tcMatchTy tmpls leqs ty1 ty2 - = case match menv initial ty1 ty2 of - Just env -> Just $ mrMapSubst (TvSubst in_scope) env - Nothing -> Nothing + = tcMatchTyX tmpls init_subst leqs ty1 ty2 where - menv = ME { me_tmpls = tmpls - , me_env = mkRnEnv2 in_scope - , me_lazy_eqs = leqs } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfType ty2) - initial = MatchResult emptyTvSubstEnv emptyBag + init_subst = mkTvSubst in_scope emptyTvSubstEnv + in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfType ty2) -- We're assuming that all the interesting -- tyvars in ty1 are in tmpls @@ -123,21 +117,12 @@ tcMatchTys :: TyVarSet -- Template tyvars -> [Type] -- Target -> Maybe (MatchResult l) -- One-shot; in principle the template -- variables could be free in the target - tcMatchTys tmpls leqs tys1 tys2 - = case match_tys menv initial tys1 tys2 of - Just env -> Just $ mrMapSubst (TvSubst in_scope) env - Nothing -> Nothing + = tcMatchTysX tmpls init_subst leqs tys1 tys2 where - menv = ME { me_tmpls = tmpls - , me_env = mkRnEnv2 in_scope - , me_lazy_eqs = leqs } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfTypes tys2) - initial = MatchResult emptyTvSubstEnv emptyBag - -- We're assuming that all the interesting - -- tyvars in tys1 are in tmpls + init_subst = mkTvSubst in_scope emptyTvSubstEnv + in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfTypes tys2) --- This is similar, but extends a substitution tcMatchTyX :: TyVarSet -- Template tyvars -> TvSubst -- Substitution to extend -> LazyEqs l -- Lazy equalities @@ -154,6 +139,23 @@ tcMatchTyX tmpls (TvSubst in_scope subst_env) leqs ty1 ty2 , me_lazy_eqs = leqs } initial = MatchResult subst_env leqs +tcMatchTysX :: TyVarSet -- Template tyvars + -> TvSubst -- Substitution to extend + -> LazyEqs l -- Lazy equalities + -> [Type] -- Template + -> [Type] -- Target + -> Maybe (MatchResult l) -- One-shot; in principle the template + -- variables could be free in the target +tcMatchTysX tmpls (TvSubst in_scope subst_env) leqs tys1 tys2 + = case match_tys menv initial tys1 tys2 of + Just env -> Just $ mrMapSubst (TvSubst in_scope) env + Nothing -> Nothing + where + menv = ME { me_tmpls = tmpls + , me_env = mkRnEnv2 in_scope + , me_lazy_eqs = leqs } + initial = MatchResult subst_env leqs + tcMatchPreds :: [TyVar] -- Bind these -> LazyEqs l -- Lazy equalities diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index 464337b7a9..ed4cd6fff7 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -15,7 +15,7 @@ module Fingerprint ( readHexFingerprint, fingerprintData, fingerprintString, - -- Re-exported from GHC.Fingerprint for GHC >= 7.7, local otherwise + -- Re-exported from GHC.Fingerprint getFileHash ) where @@ -23,13 +23,6 @@ module Fingerprint ( ##include "HsVersions.h" import Numeric ( readHex ) -#if __GLASGOW_HASKELL__ < 707 --- Only needed for getFileHash below. -import Foreign -import Panic -import System.IO -import Control.Monad ( when ) -#endif import GHC.Fingerprint @@ -39,33 +32,3 @@ readHexFingerprint s = Fingerprint w1 w2 where (s1,s2) = splitAt 16 s [(w1,"")] = readHex s1 [(w2,"")] = readHex (take 16 s2) - - -#if __GLASGOW_HASKELL__ < 707 --- Only use this if we're smaller than GHC 7.7, otherwise --- GHC.Fingerprint exports a better version of this function. - --- | Computes the hash of a given file. --- It loads the full file into memory an does not work with files bigger than --- MAXINT. -getFileHash :: FilePath -> IO Fingerprint -getFileHash path = withBinaryFile path ReadMode $ \h -> do - - fileSize <- toIntFileSize `fmap` hFileSize h - - allocaBytes fileSize $ \bufPtr -> do - n <- hGetBuf h bufPtr fileSize - when (n /= fileSize) readFailedError - fingerprintData bufPtr fileSize - - where - toIntFileSize :: Integer -> Int - toIntFileSize size - | size > fromIntegral (maxBound :: Int) = throwGhcException $ - Sorry $ "Fingerprint.getFileHash: Tried to calculate hash of file " - ++ path ++ " with size > maxBound :: Int. This is not supported." - | otherwise = fromIntegral size - - readFailedError = throwGhcException $ - Panic $ "Fingerprint.getFileHash: hGetBuf failed on interface file" -#endif diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 1ddf170cf0..fae3b9634f 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -93,6 +93,16 @@ instance Show IOEnvFailure where instance Exception IOEnvFailure +instance ExceptionMonad (IOEnv a) where + gcatch act handle = + IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s + gmask f = + IOEnv $ \s -> gmask $ \io_restore -> + let + g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) + in + unIOEnv (f g_restore) s + instance ContainsDynFlags env => HasDynFlags (IOEnv env) where getDynFlags = do env <- getEnv return $ extractDynFlags env diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 36ac6271be..2bed1d1e4f 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -61,6 +61,7 @@ module Outputable ( reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, + alwaysQualifyPackages, neverQualifyPackages, QualifyName(..), queryQual, sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs index d4e0048467..01fa071cab 100644 --- a/compiler/utils/Serialized.hs +++ b/compiler/utils/Serialized.hs @@ -96,26 +96,16 @@ deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes -> x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes -#if __GLASGOW_HASKELL__ < 707 -serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8] -serializeFixedWidthNum what = go (bitSize what) what -#else serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8] serializeFixedWidthNum what = go (finiteBitSize what) what -#endif where go :: Int -> a -> [Word8] -> [Word8] go size current rest | size <= 0 = rest | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest -#if __GLASGOW_HASKELL__ < 707 -deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b -deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k -#else deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k -#endif where go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b go size bytes k diff --git a/configure.ac b/configure.ac index 7553fc1646..d896c8bf48 100644 --- a/configure.ac +++ b/configure.ac @@ -136,8 +136,8 @@ if test "$WithGhc" = "" then AC_MSG_ERROR([GHC is required.]) fi -FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.6], - [AC_MSG_ERROR([GHC version 7.6 or later is required to compile GHC.])]) +FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.8], + [AC_MSG_ERROR([GHC version 7.8 or later is required to compile GHC.])]) if test `expr $GhcMinVersion % 2` = "1" then @@ -968,6 +968,42 @@ else fi AC_SUBST(HavePapi) +dnl large address space support (see includes/rts/storage/MBlock.h) +dnl +dnl Darwin has vm_allocate/vm_protect +dnl Linux has mmap(MAP_NORESERVE)/madv(MADV_DONTNEED) +dnl FreeBSD, Solaris and maybe other have MAP_NORESERVE/MADV_FREE +dnl (They also have MADV_DONTNEED, but it means something else!) +dnl +dnl Windows has VirtualAlloc MEM_RESERVE/MEM_COMMIT, however +dnl it counts page-table space as committed memory, and so quickly +dnl runs out of paging file when we have multiple processes reserving +dnl 1TB of address space, we get the following error: +dnl VirtualAlloc MEM_RESERVE 1099512676352 bytes failed: The paging file is too small for this operation to complete. +dnl +use_large_address_space=no +if test "$ac_cv_sizeof_void_p" -eq 8 ; then + if test "$ghc_host_os" = "darwin" ; then + use_large_address_space=yes + else + AC_CHECK_DECLS([MAP_NORESERVE, MADV_FREE, MADV_DONTNEED],[],[], +[ +#include <unistd.h> +#include <sys/types.h> +#include <sys/mman.h> +#include <fcntl.h> +]) + if test "$ac_cv_have_decl_MAP_NORESERVE" = "yes" && + test "$ac_cv_have_decl_MADV_FREE" = "yes" || + test "$ac_cv_have_decl_MADV_DONTNEED" = "yes" ; then + use_large_address_space=yes + fi + fi +fi +if test "$use_large_address_space" = "yes" ; then + AC_DEFINE([USE_LARGE_ADDRESS_SPACE], [1], [Enable single heap address space support]) +fi + if test "$HAVE_DOCBOOK_XSL" = "NO" || test "$XsltprocCmd" = "" then diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml index dc191d2638..27ad849b16 100644 --- a/docs/users_guide/7.12.1-notes.xml +++ b/docs/users_guide/7.12.1-notes.xml @@ -36,6 +36,16 @@ </listitem> <listitem> <para> + The parser now supports Haddock comments on GADT data constructors. For example, + <programlisting> + data Expr a where + -- | Just a normal sum + Sum :: Int -> Int -> Expr Int + </programlisting> + </para> + </listitem> + <listitem> + <para> Implicit parameters of the new base type <literal>GHC.Stack.CallStack</literal> are treated specially, and automatically solved for the current source @@ -85,6 +95,14 @@ This is similar to using <option>-ddump-to-file</option> with <option>-ddump-splices</option> but it always generates a file instead of being coupled to <option>-ddump-to-file</option> and only outputs code that does not exist in the .hs file and a comment for the splice location in the original file. </para> </listitem> + <listitem> + <para> + Added the option <option>-fprint-expanded-types</option>. + + When enabled, GHC also prints type-synonym-expanded types in + type errors. + </para> + </listitem> </itemizedlist> </sect3> @@ -122,7 +140,12 @@ Splices and quasi-quotes continue to only be supported by a stage 2 compiler. </para> - </listitem> + </listitem> + <listitem> + <para> + Partial type signatures can now be used in splices, see <xref linkend="pts-where"/>. + </para> + </listitem> </itemizedlist> </sect3> diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml index a0fee40749..4e33987dcb 100644 --- a/docs/users_guide/debugging.xml +++ b/docs/users_guide/debugging.xml @@ -579,6 +579,16 @@ <varlistentry> <term> + <option>-dsuppress-unfoldings</option> + <indexterm><primary><option>-dsuppress-unfoldings</option></primary></indexterm> + </term> + <listitem> + <para>Suppress the printing of the stable unfolding of a variable at its binding site.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-dsuppress-module-prefixes</option> <indexterm><primary><option>-dsuppress-module-prefixes</option></primary></indexterm> </term> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 928c6275b9..c9186006d6 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -54,6 +54,12 @@ <entry>-fno-print-unicode-syntax</entry> </row> <row> + <entry><option>-fprint-expanded-synonyms</option></entry> + <entry>In type errors, also print type-synonym-expanded types.</entry> + <entry>dynamic</entry> + <entry>-fno-print-expanded-synonyms</entry> + </row> + <row> <entry><option>-ferror-spans</option></entry> <entry>output full span in error messages</entry> <entry>dynamic</entry> @@ -3374,6 +3380,12 @@ <entry>-</entry> </row> <row> + <entry><option>-dsuppress-unfoldings</option></entry> + <entry>Suppress the printing of the stable unfolding of a variable at its binding site</entry> + <entry>dynamic</entry> + <entry>-</entry> + </row> + <row> <entry><option>-dsuppress-module-prefixes</option></entry> <entry>Suppress the printing of module qualification prefixes</entry> <entry>dynamic</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 51448d545b..9685b1d29a 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -4019,7 +4019,7 @@ as described in <xref linkend="generic-programming"/>. <listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of the class <literal>Functor</literal>, -defined in <literal>GHC.Base</literal>. +defined in <literal>GHC.Base</literal>. See <xref linkend="deriving-functor"/>. </para></listitem> <listitem><para> With <option>-XDeriveDataTypeable</option>, you can derive instances of @@ -4030,7 +4030,7 @@ deriving <literal>Typeable</literal>. <listitem><para> With <option>-XDeriveFoldable</option>, you can derive instances of the class <literal>Foldable</literal>, -defined in <literal>Data.Foldable</literal>. +defined in <literal>Data.Foldable</literal>. See <xref linkend="deriving-foldable"/>. </para></listitem> <listitem><para> With <option>-XDeriveTraversable</option>, you can derive instances of @@ -4040,6 +4040,7 @@ instance dictates the instances of <literal>Functor</literal> and <literal>Foldable</literal>, you'll probably want to derive them too, so <option>-XDeriveTraversable</option> implies <option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>. +See <xref linkend="deriving-traversable"/>. </para></listitem> </itemizedlist> You can also use a standalone deriving declaration instead @@ -4051,6 +4052,260 @@ can be mentioned in the <literal>deriving</literal> clause. </para> </sect2> +<sect2 id="deriving-functor"> +<title>Deriving <literal>Functor</literal> instances</title> + +<para>With <option>-XDeriveFunctor</option>, one can derive +<literal>Functor</literal> instances for data types of kind +<literal>* -> *</literal>. For example, this declaration: + +<programlisting> +data Example a = Ex a Char (Example a) (Example Char) + deriving Functor +</programlisting> + +would generate the following instance: + +<programlisting> +instance Functor Example where + fmap f (Ex a1 a2 a3 a4) = Ex (f a1) a2 (fmap f a3) a4 +</programlisting> +</para> + +<para>The basic algorithm for <option>-XDeriveFunctor</option> walks the +arguments of each constructor of a data type, applying a mapping function +depending on the type of each argument. Suppose we are deriving +<literal>Functor</literal> for a data type whose last type parameter is +<literal>a</literal>. Then we write the derivation of <literal>fmap</literal> +code over the type variable <literal>a</literal> for type +<literal>b</literal> as <literal>$(fmap 'a 'b)</literal>. + +<itemizedlist> +<listitem><para>If the argument's type is <literal>a</literal>, then +map over it. + +<programlisting> +$(fmap 'a 'a) = f +</programlisting> +</para></listitem> + +<listitem><para>If the argument's type does not mention <literal>a</literal>, +then do nothing to it. + +<programlisting> +$(fmap 'a 'b) = \x -> x -- when b does not contain a +</programlisting> +</para></listitem> + +<listitem><para>If the argument has a tuple type, generate map code for each +of its arguments. + +<programlisting> +$(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2) +</programlisting> +</para></listitem> + +<listitem><para>If the argument's type is a data type that mentions +<literal>a</literal>, apply <literal>fmap</literal> to it with the generated +map code for the data type's last type parameter. + +<programlisting> +$(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2 +</programlisting> +</para></listitem> + +<listitem><para>If the argument has a function type, apply generated +<literal>$(fmap)</literal> code to the result type, and apply generated +<literal>$(cofmap)</literal> code to the argument type. + +<programlisting> +$(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b)) +</programlisting> + +<literal>$(cofmap)</literal> is needed because the type parameter +<literal>a</literal> can occur in a contravariant position, which means we +need to derive a function like: + +<programlisting> +cofmap :: (a -> b) -> f b -> f a +</programlisting> + +This is pretty much the same as <literal>$(fmap)</literal>, only without the +<literal>$(cofmap 'a 'a)</literal> case: + +<programlisting> +$(cofmap 'a 'b) = \x -> x -- when b does not contain a +$(cofmap 'a 'a) = error "type variable in contravariant position" +$(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) +$(cofmap 'a '[b]) = map $(cofmap 'a 'b) +$(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2 +$(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b)) +</programlisting> + +For more information on contravariance, see +<ulink url="https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#Covariantandcontravariantpositions"> +this wiki page</ulink>. +</para></listitem> +</itemizedlist> +</para> + +<para>A data type can have a derived <literal>Functor</literal> instance if: + +<itemizedlist> +<listitem><para>It has at least one type parameter. +</para></listitem> + +<listitem><para>It does not use the last type parameter contravariantly. +</para></listitem> + +<listitem><para>It does not use the last type parameter in the "wrong place" +in any of the argument data types. For example, in: + +<programlisting> +data Right a = Right [a] (Either Int a) +</programlisting> + +the type parameter <literal>a</literal> is only ever used as the last type +argument in <literal>[]</literal> and <literal>Either</literal>, so both +<literal>[a]</literal> and <literal>Either Int a</literal> can be +<literal>fmap</literal>ped. However, in: + +<programlisting> +data Wrong a = Wrong (Either a a) +</programlisting> + +the type variable <literal>a</literal> appears in a position other than the +last, so trying to <literal>fmap</literal> an <literal>Either a a</literal> +value would not typecheck in a <literal>Functor</literal> instance. + +Note that there are two exceptions to this rule: tuple and function types, as +described above. +</para></listitem> + +<listitem><para>Its last type variable cannot be used in a +<option>-XDatatypeContexts</option> constraint. +</para></listitem> + +<listitem><para>Its last type variable cannot be used in an +<option>-XExistentialQuantification</option> or <option>-XGADTs</option> +constraint. +</para></listitem> +</itemizedlist> + +</para> +</sect2> + +<sect2 id="deriving-foldable"> +<title>Deriving <literal>Foldable</literal> instances</title> + +<para>With <option>-XDeriveFoldable</option>, one can derive +<literal>Foldable</literal> instances for data types of kind +<literal>* -> *</literal>. For example, this declaration: + +<programlisting> +data Example a = Ex a Char (Example a) (Example Char) + deriving Functor +</programlisting> + +would generate the following instance: + +<programlisting> +instance Foldable Example where + foldr f z (Ex a1 a2 a3 a4) = f a1 (foldr f z a3) + foldMap f (Ex a1 a2 a3 a4) = mappend (f a1) + (mappend mempty + (mappend (foldMap f a3) + mempty)) +</programlisting> + +The algorithm for <option>-XDeriveFoldable</option> is very similar to that of +<option>-XDeriveFunctor</option>, except that <literal>Foldable</literal> +instances are not possible for function types. The cases are: + +<programlisting> +$(foldr 'a 'b) = \x z -> z -- when b does not contain a +$(foldr 'a 'a) = f +$(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) +$(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 +</programlisting> + +Another difference between <option>-XDeriveFoldable</option> and +<option>-XDeriveFunctor</option> is that <option>-XDeriveFoldable</option> +instances can be derived for data types with existential constraints. For +example, the following data type: + +<programlisting> +data E a where + E1 :: (a ~ Int) => a -> E a + E2 :: Int -> E Int + E3 :: (a ~ Int) => a -> E Int + E4 :: (a ~ Int) => Int -> E a + +deriving instance Foldable E +</programlisting> + +would have the following <literal>Foldable</literal> instance: + +<programlisting> +instance Foldable E where + foldr f z (E1 e) = f e z + foldr f z (E2 e) = z + foldr f z (E3 e) = z + foldr f z (E4 e) = z + + foldMap f (E1 e) = f e + foldMap f (E2 e) = mempty + foldMap f (E3 e) = mempty + foldMap f (E4 e) = mempty +</programlisting> + +Notice that only the argument in <literal>E1</literal> is folded over. This is +because we only fold over constructor arguments (1) whose types are +syntactically equivalent to the last type parameter and (2) when the last type +parameter is not refined to a specific type. Only <literal>E1</literal> +satisfies both of these criteria. For more information, see +<ulink url="https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor"> +this wiki page</ulink>. +</para> +</sect2> + +<sect2 id="deriving-traversable"> +<title>Deriving <literal>Traversable</literal> instances</title> + +<para>With <option>-XDeriveTraversable</option>, one can derive +<literal>Traversable</literal> instances for data types of kind +<literal>* -> *</literal>. For example, this declaration: + +<programlisting> +data Example a = Ex a Char (Example a) (Example Char) + deriving Functor +</programlisting> + +would generate the following instance: + +<programlisting> +instance Foldable Example where + traverse f (Ex a1 a2 a3 a4) + = fmap Ex (f a) + <*> pure a2 + <*> traverse f a3 + <*> pure a4 +</programlisting> + +The algorithm for <option>-XDeriveTraversable</option> is very similar to that +of <option>-XDeriveTraversable</option>, except that +<literal>Traversable</literal> instances are not possible for function types. +The cases are: + +<programlisting> +1812 $(traverse 'a 'b) = pure -- when b does not contain a +1813 $(traverse 'a 'a) = f +1814 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> fmap (,) $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2 +1815 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 +</programlisting> +</para> +</sect2> + <sect2 id="deriving-typeable"> <title>Deriving <literal>Typeable</literal> instances</title> @@ -4991,7 +5246,12 @@ The Paterson Conditions: for each class constraint <literal>(C t1 ... tn)</liter <orderedlist> <listitem><para>No type variable has more occurrences in the constraint than in the head</para></listitem> <listitem><para>The constraint has fewer constructors and variables (taken together - and counting repetitions) than the head</para></listitem> + and counting repetitions) than the head +</para></listitem> +<listitem><para>The constraint mentions no type functions. +A type function application can in principle expand to a +type of arbitrary size, and so are rejected out of hand +</para></listitem> </orderedlist> </para></listitem> @@ -9142,6 +9402,7 @@ Extra-constraints wildcards cannot be named. Partial type signatures are allowed for bindings, pattern and expression signatures. In all other contexts, e.g. type class or type family declarations, they are disallowed. In the following example a wildcard is used in each of the three possible contexts. +Extra-constraints wildcards are not supported in pattern or expression signatures. </para> <programlisting> {-# LANGUAGE ScopedTypeVariables #-} @@ -9149,6 +9410,43 @@ foo :: _ foo (x :: _) = (x :: _) -- Inferred: forall w_. w_ -> w_ </programlisting> + + +<para> +Partial type signatures can also be used in <xref linkend="template-haskell"/> splices. +</para> + +<itemizedlist> + <listitem>Declaration splices: partial type signature are fully supported. +<programlisting> +{-# LANGUAGE TemplateHaskell, NamedWildCards #-} +$( [d| foo :: _ => _a -> _a -> _ + foo x y = x == y|] ) +</programlisting> + </listitem> + <listitem>Expression splices: anonymous and named wildcards can be used in expression signatures. + Extra-constraints wildcards are not supported, just like in regular expression signatures. +<programlisting> +{-# LANGUAGE TemplateHaskell, NamedWildCards #-} +$( [e| foo = (Just True :: _m _) |] ) +</programlisting> + </listitem> + <listitem>Typed expression splices: the same wildcards as in (untyped) expression splices are supported. + </listitem> + <listitem>Pattern splices: Template Haskell doesn't support type signatures in pattern splices. + Consequently, partial type signatures are not supported either. + </listitem> + <listitem>Type splices: only anonymous wildcards are supported in type splices. + Named and extra-constraints wildcards are not. +<programlisting> +{-# LANGUAGE TemplateHaskell #-} +foo :: $( [t| _ |] ) -> a +foo x = x +</programlisting> + </listitem> +</itemizedlist> + + </sect2> </sect1> <!-- ==================== Deferring type errors ================= --> @@ -9334,7 +9632,8 @@ Wiki page</ulink>. the quotation has type <literal>Q Type</literal>.</para></listitem> <listitem><para> <literal>[p| ... |]</literal>, where the "..." is a pattern; the quotation has type <literal>Q Pat</literal>.</para></listitem> - </itemizedlist></para></listitem> + </itemizedlist> + See <xref linkend="pts-where"/> for using partial type signatures in quotations.</para></listitem> <listitem> <para> @@ -9567,7 +9866,43 @@ module M where </orderedlist> </para> </listitem> - + <listitem> + <para> + Expression quotations accept most Haskell language constructs. + However, there are some GHC-specific extensions which expression + quotations currently do not support, including + <itemizedlist> + <listitem> + <para> + Recursive <literal>do</literal>-statements (see + <ulink url="https://ghc.haskell.org/trac/ghc/ticket/1262"> + Trac #1262</ulink>) + </para> + </listitem> + <listitem> + <para> + Pattern synonyms (see + <ulink url="https://ghc.haskell.org/trac/ghc/ticket/8761"> + Trac #8761</ulink>) + </para> + </listitem> + <listitem> + <para> + Typed holes (see + <ulink url="https://ghc.haskell.org/trac/ghc/ticket/10267"> + Trac #10267</ulink>) + </para> + </listitem> + <listitem> + <para> + Partial type signatures (see + <ulink url="https://ghc.haskell.org/trac/ghc/ticket/10548"> + Trac #10548</ulink>) + </para> + </listitem> + </itemizedlist> + </para> + </listitem> </itemizedlist> (Compared to the original paper, there are many differences of detail. diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 555c67ffbc..1d3b4b4d7c 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -274,8 +274,22 @@ exposed-modules: Network.BSD, <para>Tells GHC the the module being compiled forms part of package key <replaceable>foo</replaceable>; internally, these keys are used to determine type equality and linker symbols. - If this flag is omitted (a very common case) then the - default package <literal>main</literal> is assumed.</para> + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-library-name</option> <replaceable>hash</replaceable> + <indexterm><primary><option>-library-name</option></primary> + </indexterm></term> + <listitem> + <para>Tells GHC that the source of a Backpack file and + its textual dependencies is uniquely identified by + <replaceable>hash</replaceable>. Library names are determined + by Cabal; a usual recipe for a library name is that it is + the hash source package identifier of a package, as well as the + version hashes of all its textual dependencies. GHC will + then use this library name to generate more package keys.</para> </listitem> </varlistentry> @@ -1237,8 +1251,10 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf </itemizedlist> <para>To compile a module which is to be part of a new package, - use the <literal>-this-package-key</literal> option (<xref linkend="using-packages"/>). - Failure to use the <literal>-this-package-key</literal> option + use the <literal>-package-name</literal> (to identify the name of the package) and + <literal>-library-name</literal> (to identify the version and the version + hashes of its identities.) options (<xref linkend="using-packages"/>). + Failure to use these options when compiling a package will probably result in disaster, but you will only discover later when you attempt to import modules from the package. At this point GHC will complain that the diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index bbf9e649aa..281cf146a1 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -970,6 +970,11 @@ ghc -c A.hs written in a subset of Haskell essentially identical to that of <literal>hs-boot</literal> files.</para> + <para>Signatures can be installed like ordinary module files, + and when multiple signatures are brought into scope under the same + module name, they are merged together if their backing implementations + are the same.</para> + <para>There is one important gotcha with the current implementation: currently, instances from backing implementations will "leak" code that uses signatures, and explicit instance declarations in signatures are @@ -1145,7 +1150,7 @@ M.o : X.hi-boot locate any imported modules that come from packages. The package modules won't be included in the dependencies generated, though (but see the - <option>--include-pkg-deps</option> option below).</para> + <option>-include-pkg-deps</option> option below).</para> <para>The dependency generation phase of GHC can take some additional options, which you may find useful. @@ -1221,7 +1226,7 @@ M.o : X.hi-boot </varlistentry> <varlistentry> - <term><option>--include-pkg-deps</option></term> + <term><option>-include-pkg-deps</option></term> <listitem> <para>Regard modules imported from packages as unstable, i.e., generate dependencies on any imported package modules diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 58008a2ade..772e8b9eaa 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -896,7 +896,7 @@ ghc -c Foo.hs <varlistentry> - <term><option>--fprint-explicit-foralls, -fprint-explicit-kinds, -fprint-unicode-syntax</option> + <term><option>-fprint-explicit-foralls, -fprint-explicit-kinds, -fprint-unicode-syntax</option> <indexterm><primary><option>-fprint-explicit-foralls</option></primary></indexterm> <indexterm><primary><option>-fprint-explicit-kinds</option></primary></indexterm> <indexterm><primary><option>-fprint-unicode-syntax</option></primary></indexterm> @@ -960,6 +960,46 @@ ghci> :t (>>) </varlistentry> <varlistentry> + <term> + <option>-fprint-expanded-synonyms</option> + <indexterm><primary><option>-fprint-expanded-synonyms</option></primary></indexterm> + </term> + <listitem> + <para> + When enabled, GHC also prints type-synonym-expanded types in type + errors. + + For example, with this type synonyms: + +<screen> +type Foo = Int +type Bar = Bool +type MyBarST s = ST s Bar +</screen> + + This error message: + +<screen> +Couldn't match type 'Int' with 'Bool' +Expected type: ST s Foo + Actual type: MyBarST s +</screen> + + Becomes this: + +<screen> +Couldn't match type 'Int' with 'Bool' +Expected type: ST s Foo + Actual type: MyBarST s +Type synonyms expanded: +Expected type: ST s Int + Actual type: ST s Bool +</screen> + </para> + </listitem> + </varlistentry> + + <varlistentry> <term><option>-ferror-spans</option> <indexterm><primary><option>-ferror-spans</option></primary> </indexterm> @@ -444,7 +444,7 @@ ifeq "$$(BUILD_EXTRA_PKGS)" "YES" PACKAGES_STAGE2 += $1 endif else -PACKAGES_STAGE2 += $1 +$$(error Unknown package tag: $2) endif endef $(eval $(call foreachLibrary,addExtraPackage)) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index cd58fc2fff..d834523cff 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -424,7 +424,10 @@ interactiveUI config srcs maybe_exprs = do stop = default_stop, editor = default_editor, options = [], - line_number = 1, + -- We initialize line number as 0, not 1, because we use + -- current line number while reporting errors which is + -- incremented after reading a line. + line_number = 0, break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, @@ -536,7 +539,7 @@ runGHCi paths maybe_exprs = do let show_prompt = verbosity dflags > 0 || is_tty -- reset line number - modifyGHCiState $ \st -> st{line_number=1} + modifyGHCiState $ \st -> st{line_number=0} case maybe_exprs of Nothing -> @@ -745,7 +748,7 @@ runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do case b of Nothing -> return Nothing Just success -> do - when (not success) $ maybe (return ()) lift sourceErrorHandler + unless success $ maybe (return ()) lift sourceErrorHandler unmask $ runCommands' eh sourceErrorHandler gCmd -- | Evaluate a single line of user input (either :<command> or Haskell code). diff --git a/ghc/Main.hs b/ghc/Main.hs index fa266a24f8..201ee5d8d2 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -834,11 +834,12 @@ abiHash strs = do let modname = mkModuleName str r <- findImportedModule hsc_env modname Nothing case r of - Found _ m -> return m + FoundModule h -> return [fr_mod h] + FoundSigs hs _ -> return (map fr_mod hs) _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ cannotFindInterface dflags modname r - mods <- mapM find_it strs + mods <- fmap concat (mapM find_it strs) let get_iface modl = loadUserInterface False (text "abiHash") modl ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods diff --git a/ghc/hschooks.c b/ghc/hschooks.c index 2ebbace136..46a0944cd9 100644 --- a/ghc/hschooks.c +++ b/ghc/hschooks.c @@ -30,14 +30,10 @@ initGCStatistics(void) void defaultsHook (void) { -#if __GLASGOW_HASKELL__ >= 707 // This helps particularly with large compiles, but didn't work // very well with earlier GHCs because it caused large amounts of // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk(). RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue; -#else - RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE; -#endif RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_); diff --git a/includes/rts/storage/MBlock.h b/includes/rts/storage/MBlock.h index 29105cae93..046990eea9 100644 --- a/includes/rts/storage/MBlock.h +++ b/includes/rts/storage/MBlock.h @@ -19,203 +19,15 @@ extern void initMBlocks(void); extern void * getMBlock(void); extern void * getMBlocks(nat n); extern void freeMBlocks(void *addr, nat n); +extern void releaseFreeMemory(void); extern void freeAllMBlocks(void); -extern void *getFirstMBlock(void); -extern void *getNextMBlock(void *mblock); +extern void *getFirstMBlock(void **state); +extern void *getNextMBlock(void **state, void *mblock); #ifdef THREADED_RTS // needed for HEAP_ALLOCED below extern SpinLock gc_alloc_block_sync; #endif -/* ----------------------------------------------------------------------------- - The HEAP_ALLOCED() test. - - HEAP_ALLOCED is called FOR EVERY SINGLE CLOSURE during GC. - It needs to be FAST. - - See wiki commentary at - http://ghc.haskell.org/trac/ghc/wiki/Commentary/HeapAlloced - - Implementation of HEAP_ALLOCED - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Since heap is allocated in chunks of megablocks (MBLOCK_SIZE), we - can just use a table to record which megablocks in the address - space belong to the heap. On a 32-bit machine, with 1Mb - megablocks, using 8 bits for each entry in the table, the table - requires 4k. Lookups during GC will be fast, because the table - will be quickly cached (indeed, performance measurements showed no - measurable difference between doing the table lookup and using a - constant comparison). - - On 64-bit machines, we cache one 12-bit block map that describes - 4096 megablocks or 4GB of memory. If HEAP_ALLOCED is called for - an address that is not in the cache, it calls slowIsHeapAlloced - (see MBlock.c) which will find the block map for the 4GB block in - question. - -------------------------------------------------------------------------- */ - -#if SIZEOF_VOID_P == 4 -extern StgWord8 mblock_map[]; - -/* On a 32-bit machine a 4KB table is always sufficient */ -# define MBLOCK_MAP_SIZE 4096 -# define MBLOCK_MAP_ENTRY(p) ((StgWord)(p) >> MBLOCK_SHIFT) -# define HEAP_ALLOCED(p) mblock_map[MBLOCK_MAP_ENTRY(p)] -# define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p) - -/* ----------------------------------------------------------------------------- - HEAP_ALLOCED for 64-bit machines. - - Here are some cache layout options: - - [1] - 16KB cache of 16-bit entries, 1MB lines (capacity 8GB) - mblock size = 20 bits - entries = 8192 13 bits - line size = 0 bits (1 bit of value) - tag size = 15 bits - = 48 bits - - [2] - 32KB cache of 16-bit entries, 4MB lines (capacity 32GB) - mblock size = 20 bits - entries = 16384 14 bits - line size = 2 bits (4 bits of value) - tag size = 12 bits - = 48 bits - - [3] - 16KB cache of 16-bit entries, 2MB lines (capacity 16GB) - mblock size = 20 bits - entries = 8192 13 bits - line size = 1 bits (2 bits of value) - tag size = 14 bits - = 48 bits - - [4] - 4KB cache of 32-bit entries, 16MB lines (capacity 16GB) - mblock size = 20 bits - entries = 1024 10 bits - line size = 4 bits (16 bits of value) - tag size = 14 bits - = 48 bits - - [5] - 4KB cache of 64-bit entries, 32MB lines (capacity 16GB) - mblock size = 20 bits - entries = 512 9 bits - line size = 5 bits (32 bits of value) - tag size = 14 bits - = 48 bits - - We actually use none of the above. After much experimentation it was - found that optimising the lookup is the most important factor, - followed by reducing the number of misses. To that end, we use a - variant of [1] in which each cache entry is ((mblock << 1) + value) - where value is 0 for non-heap and 1 for heap. The cache entries can - be 32 bits, since the mblock number is 48-20 = 28 bits, and we need - 1 bit for the value. The cache can be as big as we like, but - currently we use 8k entries, giving us 8GB capacity. - - ---------------------------------------------------------------------------- */ - -#elif SIZEOF_VOID_P == 8 - -#define MBC_LINE_BITS 0 -#define MBC_TAG_BITS 15 - -#if x86_64_HOST_ARCH -// 32bits are enough for 'entry' as modern amd64 boxes have -// only 48bit sized virtual addres. -typedef StgWord32 MbcCacheLine; -#else -// 32bits is not enough here as some arches (like ia64) use -// upper address bits to distinct memory areas. -typedef StgWord64 MbcCacheLine; -#endif - -typedef StgWord8 MBlockMapLine; - -#define MBLOCK_MAP_LINE(p) (((StgWord)p & 0xffffffff) >> (MBLOCK_SHIFT + MBC_LINE_BITS)) - -#define MBC_LINE_SIZE (1<<MBC_LINE_BITS) -#define MBC_SHIFT (48 - MBLOCK_SHIFT - MBC_LINE_BITS - MBC_TAG_BITS) -#define MBC_ENTRIES (1<<MBC_SHIFT) - -extern MbcCacheLine mblock_cache[]; - -#define MBC_LINE(p) ((StgWord)p >> (MBLOCK_SHIFT + MBC_LINE_BITS)) - -#define MBLOCK_MAP_ENTRIES (1 << (32 - MBLOCK_SHIFT - MBC_LINE_BITS)) - -typedef struct { - StgWord32 addrHigh32; - MBlockMapLine lines[MBLOCK_MAP_ENTRIES]; -} MBlockMap; - -extern W_ mpc_misses; - -StgBool HEAP_ALLOCED_miss(StgWord mblock, void *p); - -INLINE_HEADER -StgBool HEAP_ALLOCED(void *p) -{ - StgWord mblock; - nat entry_no; - MbcCacheLine entry, value; - - mblock = (StgWord)p >> MBLOCK_SHIFT; - entry_no = mblock & (MBC_ENTRIES-1); - entry = mblock_cache[entry_no]; - value = entry ^ (mblock << 1); - // this formulation coaxes gcc into prioritising the value==1 - // case, which we expect to be the most common. - // __builtin_expect() didn't have any useful effect (gcc-4.3.0). - if (value == 1) { - return 1; - } else if (value == 0) { - return 0; - } else { - // putting the rest out of line turned out to be a slight - // performance improvement: - return HEAP_ALLOCED_miss(mblock,p); - } -} - -// In the parallel GC, the cache itself is safe to *read*, and can be -// updated atomically, but we need to place a lock around operations -// that touch the MBlock map. -INLINE_HEADER -StgBool HEAP_ALLOCED_GC(void *p) -{ - StgWord mblock; - nat entry_no; - MbcCacheLine entry, value; - StgBool b; - - mblock = (StgWord)p >> MBLOCK_SHIFT; - entry_no = mblock & (MBC_ENTRIES-1); - entry = mblock_cache[entry_no]; - value = entry ^ (mblock << 1); - if (value == 1) { - return 1; - } else if (value == 0) { - return 0; - } else { - // putting the rest out of line turned out to be a slight - // performance improvement: - ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync); - b = HEAP_ALLOCED_miss(mblock,p); - RELEASE_SPIN_LOCK(&gc_alloc_block_sync); - return b; - } -} - -#else -# error HEAP_ALLOCED not defined -#endif - #endif /* RTS_STORAGE_MBLOCK_H */ diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 03530bf99d96f8e8ab00cd18a18222eeba06473 +Subproject f47732a50d4bd103c5660c2fbcd77cbce8c521b diff --git a/libraries/array b/libraries/array -Subproject 0b23a9b9a0a8e89336687aa318d9142e2f542db +Subproject 604afd531aba4a96b066f6e59a08813107a9eed diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs index 7e79c347d4..a377b4f518 100644 --- a/libraries/base/Data/OldList.hs +++ b/libraries/base/Data/OldList.hs @@ -973,7 +973,7 @@ rqpart cmp x (y:ys) rle rgt r = #endif /* USE_REPORT_PRELUDE */ -- | Sort a list by comparing the results of a key function applied to each --- element. @sortOn f@ is equivalent to @sortBy . comparing f@, but has the +-- element. @sortOn f@ is equivalent to @sortBy (comparing f)@, but has the -- performance advantage of only evaluating @f@ once for each element in the -- input list. This is called the decorate-sort-undecorate paradigm, or -- Schwartzian transform. diff --git a/libraries/base/GHC/IO/Encoding.hs b/libraries/base/GHC/IO/Encoding.hs index 76c7f55e02..a690717ebd 100644 --- a/libraries/base/GHC/IO/Encoding.hs +++ b/libraries/base/GHC/IO/Encoding.hs @@ -262,9 +262,9 @@ mkTextEncoding' cfm enc = -- what we can to work with what we have. For instance, ASCII is -- easy. We match on ASCII encodings directly using several -- possible aliases (specified by RFC 1345 & Co) and for this use - -- the 'char8' encoding + -- the 'ascii' encoding Nothing - | isAscii -> return char8 + | isAscii -> return (Latin1.mkAscii cfm) | otherwise -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm) where diff --git a/libraries/base/GHC/IO/Encoding/Failure.hs b/libraries/base/GHC/IO/Encoding/Failure.hs index df5a99235a..3f9360d731 100644 --- a/libraries/base/GHC/IO/Encoding/Failure.hs +++ b/libraries/base/GHC/IO/Encoding/Failure.hs @@ -74,21 +74,22 @@ data CodingFailureMode -- unicode input that includes lone surrogate codepoints is invalid by -- definition. -- +-- -- When we used private-use characters there was a technical problem when it -- came to encoding back to bytes using iconv. The iconv code will not fail when -- it tries to encode a private-use character (as it would if trying to encode --- a surrogate), which means that we won't get a chance to replace it +-- a surrogate), which means that we wouldn't get a chance to replace it -- with the byte we originally escaped. -- -- To work around this, when filling the buffer to be encoded (in -- writeBlocks/withEncodedCString/newEncodedCString), we replaced the -- private-use characters with lone surrogates again! Likewise, when --- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we have +-- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we had -- to do the inverse process. -- -- The user of String would never see these lone surrogates, but it --- ensures that iconv will throw an error when encountering them. We --- use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose. +-- ensured that iconv will throw an error when encountering them. We +-- used lone surrogates in the range 0xDC00 to 0xDCFF for this purpose. codingFailureModeSuffix :: CodingFailureMode -> String codingFailureModeSuffix ErrorOnCodingFailure = "" diff --git a/libraries/base/GHC/IO/Encoding/Latin1.hs b/libraries/base/GHC/IO/Encoding/Latin1.hs index 34a4fca193..d24fcdfc10 100644 --- a/libraries/base/GHC/IO/Encoding/Latin1.hs +++ b/libraries/base/GHC/IO/Encoding/Latin1.hs @@ -15,7 +15,7 @@ -- Stability : internal -- Portability : non-portable -- --- UTF-32 Codecs for the IO library +-- Single-byte encodings that map directly to Unicode code points. -- -- Portions Copyright : (c) Tom Harper 2008-2009, -- (c) Bryan O'Sullivan 2009, @@ -26,9 +26,12 @@ module GHC.IO.Encoding.Latin1 ( latin1, mkLatin1, latin1_checked, mkLatin1_checked, + ascii, mkAscii, latin1_decode, + ascii_decode, latin1_encode, latin1_checked_encode, + ascii_encode, ) where import GHC.Base @@ -90,6 +93,46 @@ latin1_checked_EF cfm = setState = const $ return () }) +-- ----------------------------------------------------------------------------- +-- ASCII + +-- | @since 4.8.2.0 +ascii :: TextEncoding +ascii = mkAscii ErrorOnCodingFailure + +-- | @since 4.8.2.0 +mkAscii :: CodingFailureMode -> TextEncoding +mkAscii cfm = TextEncoding { textEncodingName = "ASCII", + mkTextDecoder = ascii_DF cfm, + mkTextEncoder = ascii_EF cfm } + +ascii_DF :: CodingFailureMode -> IO (TextDecoder ()) +ascii_DF cfm = + return (BufferCodec { + encode = ascii_decode, + recover = recoverDecode cfm, + close = return (), + getState = return (), + setState = const $ return () + }) + +ascii_EF :: CodingFailureMode -> IO (TextEncoder ()) +ascii_EF cfm = + return (BufferCodec { + encode = ascii_encode, + recover = recoverEncode cfm, + close = return (), + getState = return (), + setState = const $ return () + }) + + + +-- ----------------------------------------------------------------------------- +-- The actual decoders and encoders + +-- TODO: Eliminate code duplication between the checked and unchecked +-- versions of the decoder or encoder (but don't change the Core!) latin1_decode :: DecodeBuffer latin1_decode @@ -112,6 +155,30 @@ latin1_decode in loop ir0 ow0 +ascii_decode :: DecodeBuffer +ascii_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + if c0 > 0x7f then invalid else do + ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) + loop (ir+1) ow' + where + invalid = done InvalidSequence ir ow + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + latin1_encode :: EncodeBuffer latin1_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } @@ -132,7 +199,15 @@ latin1_encode loop ir0 ow0 latin1_checked_encode :: EncodeBuffer -latin1_checked_encode +latin1_checked_encode input output + = single_byte_checked_encode 0xff input output + +ascii_encode :: EncodeBuffer +ascii_encode input output + = single_byte_checked_encode 0x7f input output + +single_byte_checked_encode :: Int -> EncodeBuffer +single_byte_checked_encode max_legal_char input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let @@ -145,11 +220,11 @@ latin1_checked_encode | ir >= iw = done InputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir - if ord c > 0xff then invalid else do + if ord c > max_legal_char then invalid else do writeWord8Buf oraw ow (fromIntegral (ord c)) loop ir' (ow+1) where invalid = done InvalidSequence ir ow in loop ir0 ow0 - +{-# INLINE single_byte_checked_encode #-} diff --git a/libraries/base/tests/.gitignore b/libraries/base/tests/.gitignore index af90b5e47c..a430bd700a 100644 --- a/libraries/base/tests/.gitignore +++ b/libraries/base/tests/.gitignore @@ -105,6 +105,7 @@ /IO/encoding002 /IO/encoding003 /IO/encoding004 +/IO/encoding005 /IO/encodingerror001 /IO/environment001 /IO/finalization001 diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T index 43d94da452..29779457e4 100644 --- a/libraries/base/tests/IO/all.T +++ b/libraries/base/tests/IO/all.T @@ -138,6 +138,7 @@ test('encoding001', test('encoding002', normal, compile_and_run, ['']) test('encoding003', normal, compile_and_run, ['']) test('encoding004', normal, compile_and_run, ['']) +test('encoding005', normal, compile_and_run, ['']) test('environment001', [extra_clean(['environment001'])], diff --git a/libraries/base/tests/IO/encoding001.hs b/libraries/base/tests/IO/encoding001.hs index 9480abb09d..c92f8a3ef5 100644 --- a/libraries/base/tests/IO/encoding001.hs +++ b/libraries/base/tests/IO/encoding001.hs @@ -29,14 +29,7 @@ main = do chr (fromIntegral (x `shiftR` 8) .&. 0xff), chr (fromIntegral x .&. 0xff) ] hPutStr h (concatMap expand32 [ 0, 32 .. 0xD7ff ]) - -- We avoid the private-use characters at 0xEF00..0xEFFF - -- that reserved for GHC's PEP383 roundtripping implementation. - -- - -- The reason is that currently normal text containing those - -- characters will be mangled, even if we aren't using an encoding - -- created using //ROUNDTRIP. - hPutStr h (concatMap expand32 [ 0xE000, 0xE000+32 .. 0xEEFF ]) - hPutStr h (concatMap expand32 [ 0xF000, 0xF000+32 .. 0x10FFFF ]) + hPutStr h (concatMap expand32 [ 0xE000, 0xE000+32 .. 0x10FFFF ]) hClose h -- convert the UTF-32BE file into each other encoding diff --git a/libraries/base/tests/IO/encoding005.hs b/libraries/base/tests/IO/encoding005.hs new file mode 100644 index 0000000000..99db84af59 --- /dev/null +++ b/libraries/base/tests/IO/encoding005.hs @@ -0,0 +1,115 @@ +import Control.Monad +import Data.Word (Word8) +import Foreign.Ptr +import Foreign.Marshal.Array +import GHC.Foreign (peekCStringLen, withCStringLen) +import GHC.IO.Encoding.Failure (CodingFailureMode(..)) +import qualified GHC.IO.Encoding.Latin1 as Latin1 +import System.IO +import System.IO.Error + +-- Tests for single-byte encodings that map directly to Unicode +-- (module GHC.IO.Encoding.Latin1) + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right b) = Just b + +decode :: TextEncoding -> [Word8] -> IO (Maybe String) +decode enc xs = fmap eitherToMaybe . tryIOError $ withArrayLen xs (\sz p -> peekCStringLen enc (castPtr p, sz)) + +encode :: TextEncoding -> String -> IO (Maybe [Word8]) +encode enc cs = fmap eitherToMaybe . tryIOError $ withCStringLen enc cs (\(p, sz) -> peekArray sz (castPtr p)) + +testIO :: (Eq a, Show a) => IO a -> a -> IO () +testIO action expected = do + result <- action + when (result /= expected) $ + putStrLn $ "Test failed: expected " ++ show expected ++ ", but got " ++ show result + +-- Test char8-like encodings +test_char8 :: TextEncoding -> IO () +test_char8 enc = do + testIO (decode enc [0..0xff]) $ Just ['\0'..'\xff'] + + testIO (encode enc ['\0'..'\x200']) $ Just ([0..0xff] ++ [0..0xff] ++ [0]) + +-- Test latin1-like encodings +test_latin1 :: CodingFailureMode -> TextEncoding -> IO () +test_latin1 cfm enc = do + testIO (decode enc [0..0xff]) $ Just ['\0'..'\xff'] + + testIO (encode enc ['\0'..'\xff']) $ Just [0..0xff] + testIO (encode enc "\xfe\xff\x100\x101\x100\xff\xfe") $ case cfm of + ErrorOnCodingFailure -> Nothing + IgnoreCodingFailure -> Just [0xfe,0xff,0xff,0xfe] + TransliterateCodingFailure -> Just [0xfe,0xff,0x3f,0x3f,0x3f,0xff,0xfe] + -- N.B. The argument "LATIN1//TRANSLIT" to mkTextEncoding does not + -- correspond to "LATIN1//TRANSLIT" in iconv! Instead GHC asks iconv + -- to encode to "LATIN1" and uses its own "evil hack" to insert '?' + -- (ASCII 0x3f) in place of failures. See GHC.IO.Encoding.recoverEncode. + -- + -- U+0100 is LATIN CAPITAL LETTER A WITH MACRON, which iconv would + -- transliterate to 'A' (ASCII 0x41). Similarly iconv would + -- transliterate U+0101 LATIN SMALL LETTER A WITH MACRON to 'a' + -- (ASCII 0x61). + RoundtripFailure -> Nothing + +test_ascii :: CodingFailureMode -> TextEncoding -> IO () +test_ascii cfm enc = do + testIO (decode enc [0..0x7f]) $ Just ['\0'..'\x7f'] + testIO (decode enc [0x7e,0x7f,0x80,0x81,0x80,0x7f,0x7e]) $ case cfm of + ErrorOnCodingFailure -> Nothing + IgnoreCodingFailure -> Just "\x7e\x7f\x7f\x7e" + TransliterateCodingFailure -> Just "\x7e\x7f\xfffd\xfffd\xfffd\x7f\x7e" + -- Another GHC special: decode invalid input to the Char U+FFFD + -- REPLACEMENT CHARACTER. + RoundtripFailure -> Just "\x7e\x7f\xdc80\xdc81\xdc80\x7f\x7e" + -- GHC's PEP383-style String-encoding of invalid input, + -- see Note [Roundtripping] + + testIO (encode enc ['\0'..'\x7f']) $ Just [0..0x7f] + testIO (encode enc "\x7e\x7f\x80\x81\x80\x7f\xe9") $ case cfm of + ErrorOnCodingFailure -> Nothing + IgnoreCodingFailure -> Just [0x7e,0x7f,0x7f] + TransliterateCodingFailure -> Just [0x7e,0x7f,0x3f,0x3f,0x3f,0x7f,0x3f] + -- See comment in test_latin1. iconv -t ASCII//TRANSLIT would encode + -- U+00E9 LATIN SMALL LETTER E WITH ACUTE as 'e' (ASCII 0x65). + RoundtripFailure -> Nothing + + -- Test roundtripping for good measure + case cfm of + RoundtripFailure -> do + Just s <- decode enc [0..0xff] + testIO (encode enc s) $ Just [0..0xff] + _ -> return () + +main = do + putStrLn "char8 tests" + test_char8 char8 -- char8 never fails in either direction + + -- These use GHC's own implementation + putStrLn "Latin1.ascii tests" + test_ascii ErrorOnCodingFailure (Latin1.ascii) + test_ascii IgnoreCodingFailure (Latin1.mkAscii IgnoreCodingFailure) + test_ascii TransliterateCodingFailure (Latin1.mkAscii TransliterateCodingFailure) + test_ascii RoundtripFailure (Latin1.mkAscii RoundtripFailure) + + putStrLn "Latin1.latin1_checked tests" + test_latin1 ErrorOnCodingFailure (Latin1.latin1_checked) + test_latin1 IgnoreCodingFailure (Latin1.mkLatin1_checked IgnoreCodingFailure) + test_latin1 TransliterateCodingFailure (Latin1.mkLatin1_checked TransliterateCodingFailure) + test_latin1 RoundtripFailure (Latin1.mkLatin1_checked RoundtripFailure) + + -- These use iconv (normally, unless it is broken) + putStrLn "mkTextEncoding ASCII tests" + test_ascii ErrorOnCodingFailure =<< mkTextEncoding "ASCII" + test_ascii IgnoreCodingFailure =<< mkTextEncoding "ASCII//IGNORE" + test_ascii TransliterateCodingFailure =<< mkTextEncoding "ASCII//TRANSLIT" + test_ascii RoundtripFailure =<< mkTextEncoding "ASCII//ROUNDTRIP" + + putStrLn "mkTextEncoding LATIN1 tests" + test_latin1 ErrorOnCodingFailure =<< mkTextEncoding "LATIN1" + test_latin1 IgnoreCodingFailure =<< mkTextEncoding "LATIN1//IGNORE" + test_latin1 TransliterateCodingFailure =<< mkTextEncoding "LATIN1//TRANSLIT" + test_latin1 RoundtripFailure =<< mkTextEncoding "LATIN1//ROUNDTRIP" diff --git a/libraries/base/tests/IO/encoding005.stdout b/libraries/base/tests/IO/encoding005.stdout new file mode 100644 index 0000000000..664a193592 --- /dev/null +++ b/libraries/base/tests/IO/encoding005.stdout @@ -0,0 +1,5 @@ +char8 tests +Latin1.ascii tests +Latin1.latin1_checked tests +mkTextEncoding ASCII tests +mkTextEncoding LATIN1 tests diff --git a/libraries/base/tests/T8089.hs b/libraries/base/tests/T8089.hs index 2b98f94198..3273bdbe72 100644 --- a/libraries/base/tests/T8089.hs +++ b/libraries/base/tests/T8089.hs @@ -1,32 +1,4 @@ -import Control.Applicative import Control.Concurrent -import Control.Exception -import Control.Monad -import System.Environment -import System.Exit -import System.Process -import System.Timeout - -testLoop :: Int -> IO (Maybe a) -> IO (Maybe a) -testLoop 0 _ = return Nothing -testLoop i act = do - result <- act - case result of - Nothing -> threadDelay 100000 >> testLoop (i-1) act - Just x -> return (Just x) - - -forkTestChild :: IO () -forkTestChild = do - (_, _, _, hnd) <- createProcess (proc "./T8089" ["test"]) - result <- testLoop 50 $ getProcessExitCode hnd - case result of - Nothing -> terminateProcess hnd >> exitSuccess - Just exitCode -> exitWith exitCode main :: IO () -main = do - numArgs <- length <$> getArgs - if numArgs > 0 - then threadDelay maxBound - else forkTestChild +main = threadDelay maxBound diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 1c90d14e99..34176d0153 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -178,5 +178,16 @@ test('T9395', normal, compile_and_run, ['']) test('T9532', omit_ways(['debug']), compile_and_run, ['']) test('T9586', normal, compile, ['']) test('T9681', normal, compile_fail, ['']) -test('T8089', normal, compile_and_run, ['']) +# Test no runtime crash. Report success and kill with `timeout` (exit code 99) +# after a few seconds. From https://phabricator.haskell.org/D1075: +# +# "I used a fairly conservative timeout. IF there is a regression it will +# crash as soon as the timeout's C call is done. The tricky bit is +# guesstimating how much time it needs to run to guarantee it's reached the +# C call. +# Probably something like 1s is already enough, but I don't know enough to +# make an educated guess how long it needs to be guaranteed to reach the C +# call." +test('T8089', [exit_code(99), run_timeout_multiplier(0.01)], + compile_and_run, ['']) test('T9826',normal, compile_and_run,['']) diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index f796ebfc55..741248709a 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -17,6 +17,12 @@ ----------------------------------------------------------------------------- module GHC.Types ( + -- Data types that are built-in syntax + -- They are defined here, but not explicitly exported + -- + -- Lists: []( [], (:) ) + -- Type equality: (~)( Eq# ) + Bool(..), Char(..), Int(..), Word(..), Float(..), Double(..), Ordering(..), IO(..), @@ -32,6 +38,12 @@ import GHC.Prim infixr 5 : +{- ********************************************************************* +* * + Nat and Symbol +* * +********************************************************************* -} + -- | (Kind) This is the kind of type-level natural numbers. data Nat @@ -39,9 +51,32 @@ data Nat -- Declared here because class IP needs it data Symbol + +{- ********************************************************************* +* * + Lists + + NB: lists are built-in syntax, and hence not explicitly exported +* * +********************************************************************* -} + data [] a = [] | a : [a] -data {-# CTYPE "HsBool" #-} Bool = False | True + +{- ********************************************************************* +* * + Ordering +* * +********************************************************************* -} + +data Ordering = LT | EQ | GT + + +{- ********************************************************************* +* * + Int, Char, Word, Float, Double +* * +********************************************************************* -} {- | The character type 'Char' is an enumeration whose values represent Unicode (or equivalently ISO\/IEC 10646) characters (see @@ -74,7 +109,12 @@ data {-# CTYPE "HsFloat" #-} Float = F# Float# -- to the IEEE double-precision type. data {-# CTYPE "HsDouble" #-} Double = D# Double# -data Ordering = LT | EQ | GT + +{- ********************************************************************* +* * + IO +* * +********************************************************************* -} {- | A value of type @'IO' a@ is a computation which, when performed, @@ -91,12 +131,21 @@ or the '>>' and '>>=' operations from the 'Monad' class. -} newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) type role IO representational -{- -The above role annotation is redundant but is included because this role -is significant in the normalisation of FFI types. Specifically, if this -role were to become nominal (which would be very strange, indeed!), changes -elsewhere in GHC would be necessary. See [FFI type roles] in TcForeign. --} + +{- The 'type role' role annotation for IO is redundant but is included +because this role is significant in the normalisation of FFI +types. Specifically, if this role were to become nominal (which would +be very strange, indeed!), changes elsewhere in GHC would be +necessary. See [FFI type roles] in TcForeign. -} + + +{- ********************************************************************* +* * + (~) and Coercible + + NB: (~) is built-in syntax, and hence not explicitly exported +* * +********************************************************************* -} {- Note [Kind-changing of (~), Coercible and InstanceOf] @@ -182,64 +231,78 @@ newtype (<~) b a = InstOf (b -> a) -- | Alias for 'tagToEnum#'. Returns True if its parameter is 1# and False -- if it is 0#. +{- ********************************************************************* +* * + Bool, and isTrue# +* * +********************************************************************* -} + +data {-# CTYPE "HsBool" #-} Bool = False | True + {-# INLINE isTrue# #-} isTrue# :: Int# -> Bool -- See Note [Optimizing isTrue#] isTrue# x = tagToEnum# x --- Note [Optimizing isTrue#] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Current definition of isTrue# is a temporary workaround. We would like to --- have functions isTrue# and isFalse# defined like this: --- --- isTrue# :: Int# -> Bool --- isTrue# 1# = True --- isTrue# _ = False --- --- isFalse# :: Int# -> Bool --- isFalse# 0# = True --- isFalse# _ = False --- --- These functions would allow us to safely check if a tag can represent True --- or False. Using isTrue# and isFalse# as defined above will not introduce --- additional case into the code. When we scrutinize return value of isTrue# --- or isFalse#, either explicitly in a case expression or implicitly in a guard, --- the result will always be a single case expression (given that optimizations --- are turned on). This results from case-of-case transformation. Consider this --- code (this is both valid Haskell and Core): --- --- case isTrue# (a ># b) of --- True -> e1 --- False -> e2 --- --- Inlining isTrue# gives: --- --- case (case (a ># b) of { 1# -> True; _ -> False } ) of --- True -> e1 --- False -> e2 --- --- Case-of-case transforms that to: --- --- case (a ># b) of --- 1# -> case True of --- True -> e1 --- False -> e2 --- _ -> case False of --- True -> e1 --- False -> e2 --- --- Which is then simplified by case-of-known-constructor: --- --- case (a ># b) of --- 1# -> e1 --- _ -> e2 --- --- While we get good Core here, the code generator will generate very bad Cmm --- if e1 or e2 do allocation. It will push heap checks into case alternatives --- which results in about 2.5% increase in code size. Until this is improved we --- just make isTrue# an alias to tagToEnum#. This is a temporary solution (if --- you're reading this in 2023 then things went wrong). See #8326. --- +{- Note [Optimizing isTrue#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Current definition of isTrue# is a temporary workaround. We would like to +have functions isTrue# and isFalse# defined like this: + + isTrue# :: Int# -> Bool + isTrue# 1# = True + isTrue# _ = False + + isFalse# :: Int# -> Bool + isFalse# 0# = True + isFalse# _ = False + +These functions would allow us to safely check if a tag can represent True +or False. Using isTrue# and isFalse# as defined above will not introduce +additional case into the code. When we scrutinize return value of isTrue# +or isFalse#, either explicitly in a case expression or implicitly in a guard, +the result will always be a single case expression (given that optimizations +are turned on). This results from case-of-case transformation. Consider this +code (this is both valid Haskell and Core): + +case isTrue# (a ># b) of + True -> e1 + False -> e2 + +Inlining isTrue# gives: + +case (case (a ># b) of { 1# -> True; _ -> False } ) of + True -> e1 + False -> e2 + +Case-of-case transforms that to: + +case (a ># b) of + 1# -> case True of + True -> e1 + False -> e2 + _ -> case False of + True -> e1 + False -> e2 + +Which is then simplified by case-of-known-constructor: + +case (a ># b) of + 1# -> e1 + _ -> e2 + +While we get good Core here, the code generator will generate very bad Cmm +if e1 or e2 do allocation. It will push heap checks into case alternatives +which results in about 2.5% increase in code size. Until this is improved we +just make isTrue# an alias to tagToEnum#. This is a temporary solution (if +you're reading this in 2023 then things went wrong). See #8326. +-} + + +{- ********************************************************************* +* * + SPEC +* * +********************************************************************* -} -- | 'SPEC' is used by GHC in the @SpecConstr@ pass in order to inform -- the compiler when to be particularly aggressive. In particular, it diff --git a/libraries/hpc b/libraries/hpc -Subproject 154eecf3ca10f9252bf75213d091221ee3c551d +Subproject a9ecba162ae307acf12a1a783dbe1cf6ebb5729 diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs index 5670bb459f..d941c4ce85 100644 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs @@ -460,23 +460,23 @@ sqrInteger (Jn# bn) = Jp# (sqrBigNat bn) -- | Construct 'Integer' from the product of two 'Int#'s timesInt2Integer :: Int# -> Int# -> Integer -timesInt2Integer x# y# = case (# x# >=# 0#, y# >=# 0# #) of - (# 0#, 0# #) -> case timesWord2# (int2Word# (negateInt# x#)) +timesInt2Integer x# y# = case (# isTrue# (x# >=# 0#), isTrue# (y# >=# 0#) #) of + (# False, False #) -> case timesWord2# (int2Word# (negateInt# x#)) (int2Word# (negateInt# y#)) of (# 0##,l #) -> inline wordToInteger l (# h ,l #) -> Jp# (wordToBigNat2 h l) - (# _, 0# #) -> case timesWord2# (int2Word# x#) + (# True, False #) -> case timesWord2# (int2Word# x#) (int2Word# (negateInt# y#)) of (# 0##,l #) -> wordToNegInteger l (# h ,l #) -> Jn# (wordToBigNat2 h l) - (# 0#, _ #) -> case timesWord2# (int2Word# (negateInt# x#)) + (# False, True #) -> case timesWord2# (int2Word# (negateInt# x#)) (int2Word# y#) of (# 0##,l #) -> wordToNegInteger l (# h ,l #) -> Jn# (wordToBigNat2 h l) - (# _, _ #) -> case timesWord2# (int2Word# x#) + (# True, True #) -> case timesWord2# (int2Word# x#) (int2Word# y#) of (# 0##,l #) -> inline wordToInteger l (# h ,l #) -> Jp# (wordToBigNat2 h l) @@ -835,7 +835,7 @@ eqBigNatWord bn w# = isTrue# (eqBigNatWord# bn w#) eqBigNatWord# :: BigNat -> GmpLimb# -> Int# eqBigNatWord# bn w# - = sizeofBigNat# bn ==# 1# `andI#` (bigNatToWord bn `eqWord#` w#) + = (sizeofBigNat# bn ==# 1#) `andI#` (bigNatToWord bn `eqWord#` w#) -- | Same as @'indexBigNat#' bn 0\#@ @@ -1104,9 +1104,9 @@ orBigNat x@(BN# x#) y@(BN# y#) ior' a# na# b# nb# = do -- na >= nb mbn@(MBN# mba#) <- newBigNat# na# _ <- liftIO (c_mpn_ior_n mba# a# b# nb#) - _ <- case na# ==# nb# of - 0# -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) - _ -> return () + _ <- case isTrue# (na# ==# nb#) of + False -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) + True -> return () unsafeFreezeBigNat# mbn nx# = sizeofBigNat# x @@ -1123,10 +1123,10 @@ xorBigNat x@(BN# x#) y@(BN# y#) xor' a# na# b# nb# = do -- na >= nb mbn@(MBN# mba#) <- newBigNat# na# _ <- liftIO (c_mpn_xor_n mba# a# b# nb#) - case na# ==# nb# of - 0# -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) - unsafeFreezeBigNat# mbn - _ -> unsafeRenormFreezeBigNat# mbn + case isTrue# (na# ==# nb#) of + False -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) + unsafeFreezeBigNat# mbn + True -> unsafeRenormFreezeBigNat# mbn nx# = sizeofBigNat# x ny# = sizeofBigNat# y @@ -1139,9 +1139,9 @@ andnBigNat x@(BN# x#) y@(BN# y#) | True = runS $ do mbn@(MBN# mba#) <- newBigNat# nx# _ <- liftIO (c_mpn_andn_n mba# x# y# n#) - _ <- case nx# ==# n# of - 0# -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) - _ -> return () + _ <- case isTrue# (nx# ==# n#) of + False -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) + True -> return () unsafeRenormFreezeBigNat# mbn where n# | isTrue# (nx# <# ny#) = nx# @@ -1249,9 +1249,9 @@ gcdBigNat x@(BN# x#) y@(BN# y#) mbn@(MBN# mba#) <- newBigNat# nb# I# rn'# <- liftIO (c_mpn_gcd# mba# a# na# b# nb#) let rn# = narrowGmpSize# rn'# - case rn# ==# nb# of - 0# -> unsafeShrinkFreezeBigNat# mbn rn# - _ -> unsafeFreezeBigNat# mbn + case isTrue# (rn# ==# nb#) of + False -> unsafeShrinkFreezeBigNat# mbn rn# + True -> unsafeFreezeBigNat# mbn nx# = sizeofBigNat# x ny# = sizeofBigNat# y @@ -1284,9 +1284,9 @@ gcdExtSBigNat x y = case runS go of (g,s) -> (# g, s #) sn# = absI# ssn# s' <- unsafeShrinkFreezeBigNat# s sn# g' <- unsafeRenormFreezeBigNat# g - case ssn# >=# 0# of - 0# -> return ( g', NegBN s' ) - _ -> return ( g', PosBN s' ) + case isTrue# (ssn# >=# 0#) of + False -> return ( g', NegBN s' ) + True -> return ( g', PosBN s' ) !(BN# x#) = absSBigNat x !(BN# y#) = absSBigNat y @@ -1351,9 +1351,9 @@ powModSBigNat b e m@(BN# m#) = runS $ do r@(MBN# r#) <- newBigNat# mn# I# rn_# <- liftIO (integer_gmp_powm# r# b# bn# e# en# m# mn#) let rn# = narrowGmpSize# rn_# - case rn# ==# mn# of - 0# -> unsafeShrinkFreezeBigNat# r rn# - _ -> unsafeFreezeBigNat# r + case isTrue# (rn# ==# mn#) of + False -> unsafeShrinkFreezeBigNat# r rn# + True -> unsafeFreezeBigNat# r where !(BN# b#) = absSBigNat b !(BN# e#) = absSBigNat e @@ -1413,9 +1413,9 @@ recipModSBigNat x m@(BN# m#) = runS $ do r@(MBN# r#) <- newBigNat# mn# I# rn_# <- liftIO (integer_gmp_invert# r# x# xn# m# mn#) let rn# = narrowGmpSize# rn_# - case rn# ==# mn# of - 0# -> unsafeShrinkFreezeBigNat# r rn# - _ -> unsafeFreezeBigNat# r + case isTrue# (rn# ==# mn#) of + False -> unsafeShrinkFreezeBigNat# r rn# + True -> unsafeFreezeBigNat# r where !(BN# x#) = absSBigNat x xn# = ssizeofSBigNat# x @@ -1850,9 +1850,9 @@ isValidBigNat# :: BigNat -> Int# isValidBigNat# (BN# ba#) = (szq# ># 0#) `andI#` (szr# ==# 0#) `andI#` isNorm# where - isNorm# = case szq# ># 1# of - 1# -> (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## - _ -> 1# + isNorm# + | isTrue# (szq# ># 1#) = (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## + | True = 1# sz# = sizeofByteArray# ba# diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index b3ac97b5a4..a39bdd1feb 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -79,7 +79,7 @@ module Language.Haskell.TH( -- ** Constructors lifted to 'Q' -- *** Literals intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, - charL, stringL, stringPrimL, + charL, stringL, stringPrimL, charPrimL, -- *** Patterns litP, varP, tupP, conP, uInfixP, parensP, infixP, tildeP, bangP, asP, wildP, recP, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 8aed78d70b..f0431cf36b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -57,6 +57,8 @@ integerL :: Integer -> Lit integerL = IntegerL charL :: Char -> Lit charL = CharL +charPrimL :: Char -> Lit +charPrimL = CharPrimL stringL :: String -> Lit stringL = StringL stringPrimL :: [Word8] -> Lit @@ -546,6 +548,12 @@ sigT t k equalityT :: TypeQ equalityT = return EqualityT +wildCardT :: TypeQ +wildCardT = return (WildCardT Nothing) + +namedWildCardT :: Name -> TypeQ +namedWildCardT = return . WildCardT . Just + {-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-} classP :: Name -> [Q Type] -> Q Pred classP cla tys diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index e5cab65185..c8f42ef55d 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -224,6 +224,7 @@ pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0) (double (fromRational x) <> text "##") pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) pprLit _ (CharL c) = text (show c) +pprLit _ (CharPrimL c) = text (show c) <> char '#' pprLit _ (StringL s) = pprString s pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' pprLit i (RationalL rat) = parensIf (i > noPrec) $ @@ -499,6 +500,7 @@ pprParendType PromotedConsT = text "(':)" pprParendType StarT = char '*' pprParendType ConstraintT = text "Constraint" pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) +pprParendType (WildCardT mbName) = char '_' <> maybe empty ppr mbName pprParendType other = parens (ppr other) instance Ppr Type where diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 8ab183c745..d2233a19df 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2,12 +2,8 @@ DeriveGeneric, FlexibleInstances, DefaultSignatures, ScopedTypeVariables, Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} -#else -{-# OPTIONS_GHC -w #-} -- -fno-warn-inline-rule-shadowing doesn't exist -#endif #if MIN_VERSION_base(4,8,0) #define HAS_NATURAL @@ -178,9 +174,7 @@ instance Applicative Q where -- ----------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 707 type role TExp nominal -- See Note [Role of TExp] -#endif newtype TExp a = TExp { unType :: Exp } unTypeQ :: Q (TExp a) -> Q Exp @@ -1230,6 +1224,7 @@ data Lit = CharL Char | FloatPrimL Rational | DoublePrimL Rational | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# + | CharPrimL Char deriving( Show, Eq, Ord, Data, Typeable, Generic ) -- We could add Int, Float, Double etc, as we do in HsLit, @@ -1480,6 +1475,7 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<t | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ + | WildCardT (Maybe Name) -- ^ @_, _a, etc.@ deriving( Show, Eq, Ord, Data, Typeable, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c index 2c01113f63..34f976db4d 100644 --- a/rts/CheckUnload.c +++ b/rts/CheckUnload.c @@ -271,7 +271,8 @@ void checkUnload (StgClosure *static_objects) addrs = allocHashTable(); - for (p = static_objects; p != END_OF_STATIC_LIST; p = link) { + for (p = static_objects; p != END_OF_STATIC_OBJECT_LIST; p = link) { + p = UNTAG_STATIC_LIST_PTR(p); checkAddress(addrs, p); info = get_itbl(p); link = *STATIC_LINK(info, p); @@ -279,8 +280,9 @@ void checkUnload (StgClosure *static_objects) // CAFs on revertible_caf_list are not on static_objects for (p = (StgClosure*)revertible_caf_list; - p != END_OF_STATIC_LIST; + p != END_OF_CAF_LIST; p = ((StgIndStatic *)p)->static_link) { + p = UNTAG_STATIC_LIST_PTR(p); checkAddress(addrs, p); } diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 78daa892ad..ba58c199f0 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -1881,7 +1881,8 @@ resetStaticObjectForRetainerProfiling( StgClosure *static_objects ) count = 0; #endif p = static_objects; - while (p != END_OF_STATIC_LIST) { + while (p != END_OF_STATIC_OBJECT_LIST) { + p = UNTAG_STATIC_LIST_PTR(p); #ifdef DEBUG_RETAINER count++; #endif diff --git a/rts/Sparks.c b/rts/Sparks.c index ada2adfd3a..ec075805bf 100644 --- a/rts/Sparks.c +++ b/rts/Sparks.c @@ -14,6 +14,7 @@ #include "Trace.h" #include "Prelude.h" #include "Sparks.h" +#include "sm/HeapAlloc.h" #if defined(THREADED_RTS) diff --git a/rts/posix/OSMem.c b/rts/posix/OSMem.c index 359df7022b..125ae10367 100644 --- a/rts/posix/OSMem.c +++ b/rts/posix/OSMem.c @@ -13,6 +13,7 @@ #include "RtsUtils.h" #include "sm/OSMem.h" +#include "sm/HeapAlloc.h" #ifdef HAVE_UNISTD_H #include <unistd.h> @@ -72,23 +73,67 @@ void osMemInit(void) -------------------------------------------------------------------------- */ -// A wrapper around mmap(), to abstract away from OS differences in -// the mmap() interface. +/* + A wrapper around mmap(), to abstract away from OS differences in + the mmap() interface. + + It supports the following operations: + - reserve: find a new chunk of available address space, and make it so + that we own it (no other library will get it), but don't actually + allocate memory for it + the addr is a hint for where to place the memory (and most + of the time the OS happily ignores!) + - commit: given a chunk of address space that we know we own, make sure + there is some memory backing it + the addr is not a hint, it must point into previously reserved + address space, or bad things happen + - reserve&commit: do both at the same time + + The naming is chosen from the Win32 API (VirtualAlloc) which does the + same thing and has done so forever, while support for this in Unix systems + has only been added recently and is hidden in the posix portability mess. + It is confusing because to get the reserve behavior we need MAP_NORESERVE + (which tells the kernel not to allocate backing space), but heh... +*/ +enum +{ + MEM_RESERVE = 1, + MEM_COMMIT = 2, + MEM_RESERVE_AND_COMMIT = MEM_RESERVE | MEM_COMMIT +}; static void * -my_mmap (void *addr, W_ size) +my_mmap (void *addr, W_ size, int operation) { void *ret; + int prot, flags; + + if (operation & MEM_COMMIT) + prot = PROT_READ | PROT_WRITE; + else + prot = PROT_NONE; + if (operation == MEM_RESERVE) + flags = MAP_NORESERVE; + else if (operation == MEM_COMMIT) + flags = MAP_FIXED; + else + flags = 0; #if defined(solaris2_HOST_OS) || defined(irix_HOST_OS) { - int fd = open("/dev/zero",O_RDONLY); - ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0); - close(fd); + if (operation & MEM_RESERVE) + { + int fd = open("/dev/zero",O_RDONLY); + ret = mmap(addr, size, prot, flags | MAP_PRIVATE, fd, 0); + close(fd); + } + else + { + ret = mmap(addr, size, prot, flags | MAP_PRIVATE, -1, 0); + } } #elif hpux_HOST_OS - ret = mmap(addr, size, PROT_READ | PROT_WRITE, - MAP_ANONYMOUS | MAP_PRIVATE, -1, 0); + ret = mmap(addr, size, prot, flags | MAP_ANONYMOUS | MAP_PRIVATE, -1, 0); #elif darwin_HOST_OS // Without MAP_FIXED, Apple's mmap ignores addr. // With MAP_FIXED, it overwrites already mapped regions, whic @@ -100,10 +145,16 @@ my_mmap (void *addr, W_ size) kern_return_t err = 0; ret = addr; - if(addr) // try to allocate at address - err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, FALSE); - if(!addr || err) // try to allocate anywhere - err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, TRUE); + + if(operation & MEM_RESERVE) + { + if(addr) // try to allocate at address + err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, + size, FALSE); + if(!addr || err) // try to allocate anywhere + err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, + size, TRUE); + } if(err) { // don't know what the error codes mean exactly, assume it's @@ -111,23 +162,24 @@ my_mmap (void *addr, W_ size) errorBelch("memory allocation failed (requested %" FMT_Word " bytes)", size); stg_exit(EXIT_FAILURE); - } else { + } + + if(operation & MEM_COMMIT) { vm_protect(mach_task_self(), (vm_address_t)ret, size, FALSE, VM_PROT_READ|VM_PROT_WRITE); } + #elif linux_HOST_OS - ret = mmap(addr, size, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); + ret = mmap(addr, size, prot, flags | MAP_ANON | MAP_PRIVATE, -1, 0); if (ret == (void *)-1 && errno == EPERM) { // Linux may return EPERM if it tried to give us // a chunk of address space below mmap_min_addr, // See Trac #7500. - if (addr != 0) { + if (addr != 0 && (operation & MEM_RESERVE)) { // Try again with no hint address. // It's not clear that this can ever actually help, // but since our alternative is to abort, we may as well try. - ret = mmap(0, size, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); + ret = mmap(0, size, prot, flags | MAP_ANON | MAP_PRIVATE, -1, 0); } if (ret == (void *)-1 && errno == EPERM) { // Linux is not willing to give us any mapping, @@ -137,8 +189,7 @@ my_mmap (void *addr, W_ size) } } #else - ret = mmap(addr, size, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); + ret = mmap(addr, size, prot, flags | MAP_ANON | MAP_PRIVATE, -1, 0); #endif if (ret == (void *)-1) { @@ -168,7 +219,7 @@ gen_map_mblocks (W_ size) // Try to map a larger block, and take the aligned portion from // it (unmap the rest). size += MBLOCK_SIZE; - ret = my_mmap(0, size); + ret = my_mmap(0, size, MEM_RESERVE_AND_COMMIT); // unmap the slop bits around the chunk we allocated slop = (W_)ret & MBLOCK_MASK; @@ -207,7 +258,7 @@ osGetMBlocks(nat n) // use gen_map_mblocks the first time. ret = gen_map_mblocks(size); } else { - ret = my_mmap(next_request, size); + ret = my_mmap(next_request, size, MEM_RESERVE_AND_COMMIT); if (((W_)ret & MBLOCK_MASK) != 0) { // misaligned block! @@ -244,10 +295,11 @@ void osReleaseFreeMemory(void) { void osFreeAllMBlocks(void) { void *mblock; + void *state; - for (mblock = getFirstMBlock(); + for (mblock = getFirstMBlock(&state); mblock != NULL; - mblock = getNextMBlock(mblock)) { + mblock = getNextMBlock(&state, mblock)) { munmap(mblock, MBLOCK_SIZE); } } @@ -318,3 +370,103 @@ void setExecutable (void *p, W_ len, rtsBool exec) barf("setExecutable: failed to protect 0x%p\n", p); } } + +#ifdef USE_LARGE_ADDRESS_SPACE + +static void * +osTryReserveHeapMemory (void *hint) +{ + void *base, *top; + void *start, *end; + + /* We try to allocate MBLOCK_SPACE_SIZE + MBLOCK_SIZE, + because we need memory which is MBLOCK_SIZE aligned, + and then we discard what we don't need */ + + base = my_mmap(hint, MBLOCK_SPACE_SIZE + MBLOCK_SIZE, MEM_RESERVE); + top = (void*)((W_)base + MBLOCK_SPACE_SIZE + MBLOCK_SIZE); + + if (((W_)base & MBLOCK_MASK) != 0) { + start = MBLOCK_ROUND_UP(base); + end = MBLOCK_ROUND_DOWN(top); + ASSERT(((W_)end - (W_)start) == MBLOCK_SPACE_SIZE); + + if (munmap(base, (W_)start-(W_)base) < 0) { + sysErrorBelch("unable to release slop before heap"); + } + if (munmap(end, (W_)top-(W_)end) < 0) { + sysErrorBelch("unable to release slop after heap"); + } + } else { + start = base; + } + + return start; +} + +void *osReserveHeapMemory(void) +{ + int attempt; + void *at; + + /* We want to ensure the heap starts at least 8 GB inside the address space, + to make sure that any dynamically loaded code will be close enough to the + original code so that short relocations will work. This is in particular + important on Darwin/Mach-O, because object files not compiled as shared + libraries are position independent but cannot be loaded about 4GB. + + We do so with a hint to the mmap, and we verify the OS satisfied our + hint. We loop a few times in case there is already something allocated + there, but we bail if we cannot allocate at all. + */ + + attempt = 0; + do { + at = osTryReserveHeapMemory((void*)((W_)8 * (1 << 30) + + attempt * BLOCK_SIZE)); + } while ((W_)at < ((W_)8 * (1 << 30))); + + return at; +} + +void osCommitMemory(void *at, W_ size) +{ + my_mmap(at, size, MEM_COMMIT); +} + +void osDecommitMemory(void *at, W_ size) +{ + int r; + + // First make the memory unaccessible (so that we get a segfault + // at the next attempt to touch it) + // We only do this in DEBUG because it forces the OS to remove + // all MMU entries for this page range, and there is no reason + // to do so unless there is memory pressure +#ifdef DEBUG + r = mprotect(at, size, PROT_NONE); + if(r < 0) + sysErrorBelch("unable to make released memory unaccessible"); +#endif + +#ifdef MADV_FREE + // Try MADV_FREE first, FreeBSD has both and MADV_DONTNEED + // just swaps memory out + r = madvise(at, size, MADV_FREE); +#else + r = madvise(at, size, MADV_DONTNEED); +#endif + if(r < 0) + sysErrorBelch("unable to decommit memory"); +} + +void osReleaseHeapMemory(void) +{ + int r; + + r = munmap((void*)mblock_address_space_begin, MBLOCK_SPACE_SIZE); + if(r < 0) + sysErrorBelch("unable to release address space"); +} + +#endif diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c index c2a5913963..e721fb13b6 100644 --- a/rts/sm/BlockAlloc.c +++ b/rts/sm/BlockAlloc.c @@ -736,7 +736,14 @@ void returnMemoryToOS(nat n /* megablocks */) } free_mblock_list = bd; - osReleaseFreeMemory(); + // Ask the OS to release any address space portion + // that was associated with the just released MBlocks + // + // Historically, we used to ask the OS directly (via + // osReleaseFreeMemory()) - now the MBlock layer might + // have a reason to preserve the address space range, + // so we keep it + releaseFreeMemory(); IF_DEBUG(gc, if (n != 0) { @@ -869,11 +876,12 @@ void reportUnmarkedBlocks (void) { void *mblock; + void *state; bdescr *bd; debugBelch("Unreachable blocks:\n"); - for (mblock = getFirstMBlock(); mblock != NULL; - mblock = getNextMBlock(mblock)) { + for (mblock = getFirstMBlock(&state); mblock != NULL; + mblock = getNextMBlock(&state, mblock)) { for (bd = FIRST_BDESCR(mblock); bd <= LAST_BDESCR(mblock); ) { if (!(bd->flags & BF_KNOWN) && bd->free != (P_)-1) { debugBelch(" %p\n",bd); diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index a053dc3b4e..4ee88da11c 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -197,8 +197,8 @@ thread_static( StgClosure* p ) // keep going until we've threaded all the objects on the linked // list... - while (p != END_OF_STATIC_LIST) { - + while (p != END_OF_STATIC_OBJECT_LIST) { + p = UNTAG_STATIC_LIST_PTR(p); info = get_itbl(p); switch (info->type) { diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index b0ef807768..bc8cb9ad13 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -324,6 +324,38 @@ evacuate_large(StgPtr p) } /* ---------------------------------------------------------------------------- + Evacuate static objects + + When a static object is visited for the first time in this GC, it + is chained on to the gct->static_objects list. + + evacuate_static_object (link_field, q) + - link_field must be STATIC_LINK(q) + ------------------------------------------------------------------------- */ + +STATIC_INLINE void +evacuate_static_object (StgClosure **link_field, StgClosure *q) +{ + StgWord link = (StgWord)*link_field; + + // See Note [STATIC_LINK fields] for how the link field bits work + if ((((StgWord)(link)&STATIC_BITS) | prev_static_flag) != 3) { + StgWord new_list_head = (StgWord)q | static_flag; +#ifndef THREADED_RTS + *link_field = gct->static_objects; + gct->static_objects = (StgClosure *)new_list_head; +#else + StgWord prev; + prev = cas((StgVolatilePtr)link_field, link, + (StgWord)gct->static_objects); + if (prev == link) { + gct->static_objects = (StgClosure *)new_list_head; + } +#endif + } +} + +/* ---------------------------------------------------------------------------- Evacuate This is called (eventually) for every live object in the system. @@ -392,38 +424,13 @@ loop: case THUNK_STATIC: if (info->srt_bitmap != 0) { - if (*THUNK_STATIC_LINK((StgClosure *)q) == NULL) { -#ifndef THREADED_RTS - *THUNK_STATIC_LINK((StgClosure *)q) = gct->static_objects; - gct->static_objects = (StgClosure *)q; -#else - StgPtr link; - link = (StgPtr)cas((StgPtr)THUNK_STATIC_LINK((StgClosure *)q), - (StgWord)NULL, - (StgWord)gct->static_objects); - if (link == NULL) { - gct->static_objects = (StgClosure *)q; - } -#endif - } + evacuate_static_object(THUNK_STATIC_LINK((StgClosure *)q), q); } return; case FUN_STATIC: - if (info->srt_bitmap != 0 && - *FUN_STATIC_LINK((StgClosure *)q) == NULL) { -#ifndef THREADED_RTS - *FUN_STATIC_LINK((StgClosure *)q) = gct->static_objects; - gct->static_objects = (StgClosure *)q; -#else - StgPtr link; - link = (StgPtr)cas((StgPtr)FUN_STATIC_LINK((StgClosure *)q), - (StgWord)NULL, - (StgWord)gct->static_objects); - if (link == NULL) { - gct->static_objects = (StgClosure *)q; - } -#endif + if (info->srt_bitmap != 0) { + evacuate_static_object(FUN_STATIC_LINK((StgClosure *)q), q); } return; @@ -432,39 +439,11 @@ loop: * on the CAF list, so don't do anything with it here (we'll * scavenge it later). */ - if (*IND_STATIC_LINK((StgClosure *)q) == NULL) { -#ifndef THREADED_RTS - *IND_STATIC_LINK((StgClosure *)q) = gct->static_objects; - gct->static_objects = (StgClosure *)q; -#else - StgPtr link; - link = (StgPtr)cas((StgPtr)IND_STATIC_LINK((StgClosure *)q), - (StgWord)NULL, - (StgWord)gct->static_objects); - if (link == NULL) { - gct->static_objects = (StgClosure *)q; - } -#endif - } + evacuate_static_object(IND_STATIC_LINK((StgClosure *)q), q); return; case CONSTR_STATIC: - if (*STATIC_LINK(info,(StgClosure *)q) == NULL) { -#ifndef THREADED_RTS - *STATIC_LINK(info,(StgClosure *)q) = gct->static_objects; - gct->static_objects = (StgClosure *)q; -#else - StgPtr link; - link = (StgPtr)cas((StgPtr)STATIC_LINK(info,(StgClosure *)q), - (StgWord)NULL, - (StgWord)gct->static_objects); - if (link == NULL) { - gct->static_objects = (StgClosure *)q; - } -#endif - } - /* I am assuming that static_objects pointers are not - * written to other objects, and thus, no need to retag. */ + evacuate_static_object(STATIC_LINK(info,(StgClosure *)q), q); return; case CONSTR_NOCAF_STATIC: diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 52d7f98fa0..e6a23395eb 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -134,6 +134,9 @@ long copied; // *words* copied & scavenged during this GC rtsBool work_stealing; +nat static_flag = STATIC_FLAG_B; +nat prev_static_flag = STATIC_FLAG_A; + DECLARE_GCT /* ----------------------------------------------------------------------------- @@ -141,7 +144,6 @@ DECLARE_GCT -------------------------------------------------------------------------- */ static void mark_root (void *user, StgClosure **root); -static void zero_static_object_list (StgClosure* first_static); static void prepare_collected_gen (generation *gen); static void prepare_uncollected_gen (generation *gen); static void init_gc_thread (gc_thread *t); @@ -246,6 +248,12 @@ GarbageCollect (nat collect_gen, N = collect_gen; major_gc = (N == RtsFlags.GcFlags.generations-1); + if (major_gc) { + prev_static_flag = static_flag; + static_flag = + static_flag == STATIC_FLAG_A ? STATIC_FLAG_B : STATIC_FLAG_A; + } + #if defined(THREADED_RTS) work_stealing = RtsFlags.ParFlags.parGcLoadBalancingEnabled && N >= RtsFlags.ParFlags.parGcLoadBalancingGen; @@ -672,20 +680,6 @@ GarbageCollect (nat collect_gen, resetStaticObjectForRetainerProfiling(gct->scavenged_static_objects); #endif - // zero the scavenged static object list - if (major_gc) { - nat i; - if (n_gc_threads == 1) { - zero_static_object_list(gct->scavenged_static_objects); - } else { - for (i = 0; i < n_gc_threads; i++) { - if (!gc_threads[i]->idle) { - zero_static_object_list(gc_threads[i]->scavenged_static_objects); - } - } - } - } - // Start any pending finalizers. Must be after // updateStableTables() and stableUnlock() (see #4221). RELEASE_SM_LOCK; @@ -1427,8 +1421,8 @@ collect_pinned_object_blocks (void) static void init_gc_thread (gc_thread *t) { - t->static_objects = END_OF_STATIC_LIST; - t->scavenged_static_objects = END_OF_STATIC_LIST; + t->static_objects = END_OF_STATIC_OBJECT_LIST; + t->scavenged_static_objects = END_OF_STATIC_OBJECT_LIST; t->scan_bd = NULL; t->mut_lists = t->cap->mut_lists; t->evac_gen_no = 0; @@ -1465,24 +1459,6 @@ mark_root(void *user USED_IF_THREADS, StgClosure **root) SET_GCT(saved_gct); } -/* ----------------------------------------------------------------------------- - Initialising the static object & mutable lists - -------------------------------------------------------------------------- */ - -static void -zero_static_object_list(StgClosure* first_static) -{ - StgClosure* p; - StgClosure* link; - const StgInfoTable *info; - - for (p = first_static; p != END_OF_STATIC_LIST; p = link) { - info = get_itbl(p); - link = *STATIC_LINK(info, p); - *STATIC_LINK(info,p) = NULL; - } -} - /* ---------------------------------------------------------------------------- Reset the sizes of the older generations when we do a major collection. @@ -1728,7 +1704,7 @@ static void gcCAFs(void) p = debug_caf_list; prev = NULL; - for (p = debug_caf_list; p != (StgIndStatic*)END_OF_STATIC_LIST; + for (p = debug_caf_list; p != (StgIndStatic*)END_OF_CAF_LIST; p = (StgIndStatic*)p->saved_info) { info = get_itbl((StgClosure*)p); diff --git a/rts/sm/GC.h b/rts/sm/GC.h index 571aa07110..5744eb95a8 100644 --- a/rts/sm/GC.h +++ b/rts/sm/GC.h @@ -16,6 +16,8 @@ #include "BeginPrivate.h" +#include "HeapAlloc.h" + void GarbageCollect (rtsBool force_major_gc, rtsBool do_heap_census, nat gc_type, Capability *cap); diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c index 13316e4d29..d3cbdaefb4 100644 --- a/rts/sm/GCAux.c +++ b/rts/sm/GCAux.c @@ -118,14 +118,14 @@ revertCAFs( void ) StgIndStatic *c; for (c = revertible_caf_list; - c != (StgIndStatic *)END_OF_STATIC_LIST; + c != (StgIndStatic *)END_OF_CAF_LIST; c = (StgIndStatic *)c->static_link) { SET_INFO((StgClosure *)c, c->saved_info); c->saved_info = NULL; // could, but not necessary: c->static_link = NULL; } - revertible_caf_list = (StgIndStatic*)END_OF_STATIC_LIST; + revertible_caf_list = (StgIndStatic*)END_OF_CAF_LIST; } void @@ -134,15 +134,17 @@ markCAFs (evac_fn evac, void *user) StgIndStatic *c; for (c = dyn_caf_list; - c != (StgIndStatic*)END_OF_STATIC_LIST; + c != (StgIndStatic*)END_OF_CAF_LIST; c = (StgIndStatic *)c->static_link) { + c = (StgIndStatic *)UNTAG_STATIC_LIST_PTR(c); evac(user, &c->indirectee); } for (c = revertible_caf_list; - c != (StgIndStatic*)END_OF_STATIC_LIST; + c != (StgIndStatic*)END_OF_CAF_LIST; c = (StgIndStatic *)c->static_link) { + c = (StgIndStatic *)UNTAG_STATIC_LIST_PTR(c); evac(user, &c->indirectee); } } diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index cbe4346afe..d42b89f973 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -131,8 +131,11 @@ typedef struct gc_thread_ { // during GC without accessing the block // allocators spin lock. - StgClosure* static_objects; // live static objects - StgClosure* scavenged_static_objects; // static objects scavenged so far + // These two lists are chained through the STATIC_LINK() fields of static + // objects. Pointers are tagged with the current static_flag, so before + // following a pointer, untag it with UNTAG_STATIC_LIST_PTR(). + StgClosure* static_objects; // live static objects + StgClosure* scavenged_static_objects; // static objects scavenged so far W_ gc_count; // number of GCs this thread has done diff --git a/rts/sm/HeapAlloc.h b/rts/sm/HeapAlloc.h new file mode 100644 index 0000000000..c914b5db40 --- /dev/null +++ b/rts/sm/HeapAlloc.h @@ -0,0 +1,224 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2006-2008 + * + * The HEAP_ALLOCED() test. + * + * ---------------------------------------------------------------------------*/ + +#ifndef SM_HEAP_ALLOC_H +#define SM_HEAP_ALLOC_H + +#include "BeginPrivate.h" + +/* ----------------------------------------------------------------------------- + The HEAP_ALLOCED() test. + + HEAP_ALLOCED is called FOR EVERY SINGLE CLOSURE during GC. + It needs to be FAST. + + See wiki commentary at + http://ghc.haskell.org/trac/ghc/wiki/Commentary/HeapAlloced + + Implementation of HEAP_ALLOCED + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Since heap is allocated in chunks of megablocks (MBLOCK_SIZE), we + can just use a table to record which megablocks in the address + space belong to the heap. On a 32-bit machine, with 1Mb + megablocks, using 8 bits for each entry in the table, the table + requires 4k. Lookups during GC will be fast, because the table + will be quickly cached (indeed, performance measurements showed no + measurable difference between doing the table lookup and using a + constant comparison). + + On 64-bit machines, we have two possibilities. One is to request + a single chunk of address space that we deem "large enough" + (currently 1TB, could easily be extended to, say 16TB or more). + Memory from that chunk is GC memory, everything else is not. This + case is tricky in that it requires support from the OS to allocate + address space without allocating memory (in practice, all modern + OSes do this). It's also tricky in that it is the only case where + a successful HEAP_ALLOCED(p) check can trigger a segfault when + accessing p (and for debugging purposes, it will). + + Alternatively, the older implementation caches one 12-bit block map + that describes 4096 megablocks or 4GB of memory. If HEAP_ALLOCED is + called for an address that is not in the cache, it calls + slowIsHeapAlloced (see MBlock.c) which will find the block map for + the 4GB block in question. + -------------------------------------------------------------------------- */ + +#ifdef USE_LARGE_ADDRESS_SPACE + +extern W_ mblock_address_space_begin; +# define MBLOCK_SPACE_SIZE ((StgWord)1 << 40) /* 1 TB */ +# define HEAP_ALLOCED(p) ((W_)(p) >= mblock_address_space_begin && \ + (W_)(p) < (mblock_address_space_begin + \ + MBLOCK_SPACE_SIZE)) +# define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p) + +#elif SIZEOF_VOID_P == 4 +extern StgWord8 mblock_map[]; + +/* On a 32-bit machine a 4KB table is always sufficient */ +# define MBLOCK_MAP_SIZE 4096 +# define MBLOCK_MAP_ENTRY(p) ((StgWord)(p) >> MBLOCK_SHIFT) +# define HEAP_ALLOCED(p) mblock_map[MBLOCK_MAP_ENTRY(p)] +# define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p) + +/* ----------------------------------------------------------------------------- + HEAP_ALLOCED for 64-bit machines (without LARGE_ADDRESS_SPACE). + + Here are some cache layout options: + + [1] + 16KB cache of 16-bit entries, 1MB lines (capacity 8GB) + mblock size = 20 bits + entries = 8192 13 bits + line size = 0 bits (1 bit of value) + tag size = 15 bits + = 48 bits + + [2] + 32KB cache of 16-bit entries, 4MB lines (capacity 32GB) + mblock size = 20 bits + entries = 16384 14 bits + line size = 2 bits (4 bits of value) + tag size = 12 bits + = 48 bits + + [3] + 16KB cache of 16-bit entries, 2MB lines (capacity 16GB) + mblock size = 20 bits + entries = 8192 13 bits + line size = 1 bits (2 bits of value) + tag size = 14 bits + = 48 bits + + [4] + 4KB cache of 32-bit entries, 16MB lines (capacity 16GB) + mblock size = 20 bits + entries = 1024 10 bits + line size = 4 bits (16 bits of value) + tag size = 14 bits + = 48 bits + + [5] + 4KB cache of 64-bit entries, 32MB lines (capacity 16GB) + mblock size = 20 bits + entries = 512 9 bits + line size = 5 bits (32 bits of value) + tag size = 14 bits + = 48 bits + + We actually use none of the above. After much experimentation it was + found that optimising the lookup is the most important factor, + followed by reducing the number of misses. To that end, we use a + variant of [1] in which each cache entry is ((mblock << 1) + value) + where value is 0 for non-heap and 1 for heap. The cache entries can + be 32 bits, since the mblock number is 48-20 = 28 bits, and we need + 1 bit for the value. The cache can be as big as we like, but + currently we use 8k entries, giving us 8GB capacity. + + ---------------------------------------------------------------------------- */ + +#elif SIZEOF_VOID_P == 8 + +#define MBC_LINE_BITS 0 +#define MBC_TAG_BITS 15 + +#if x86_64_HOST_ARCH +// 32bits are enough for 'entry' as modern amd64 boxes have +// only 48bit sized virtual addres. +typedef StgWord32 MbcCacheLine; +#else +// 32bits is not enough here as some arches (like ia64) use +// upper address bits to distinct memory areas. +typedef StgWord64 MbcCacheLine; +#endif + +typedef StgWord8 MBlockMapLine; + +#define MBLOCK_MAP_LINE(p) (((StgWord)p & 0xffffffff) >> (MBLOCK_SHIFT + MBC_LINE_BITS)) + +#define MBC_LINE_SIZE (1<<MBC_LINE_BITS) +#define MBC_SHIFT (48 - MBLOCK_SHIFT - MBC_LINE_BITS - MBC_TAG_BITS) +#define MBC_ENTRIES (1<<MBC_SHIFT) + +extern MbcCacheLine mblock_cache[]; + +#define MBC_LINE(p) ((StgWord)p >> (MBLOCK_SHIFT + MBC_LINE_BITS)) + +#define MBLOCK_MAP_ENTRIES (1 << (32 - MBLOCK_SHIFT - MBC_LINE_BITS)) + +typedef struct { + StgWord32 addrHigh32; + MBlockMapLine lines[MBLOCK_MAP_ENTRIES]; +} MBlockMap; + +extern W_ mpc_misses; + +StgBool HEAP_ALLOCED_miss(StgWord mblock, void *p); + +INLINE_HEADER +StgBool HEAP_ALLOCED(void *p) +{ + StgWord mblock; + nat entry_no; + MbcCacheLine entry, value; + + mblock = (StgWord)p >> MBLOCK_SHIFT; + entry_no = mblock & (MBC_ENTRIES-1); + entry = mblock_cache[entry_no]; + value = entry ^ (mblock << 1); + // this formulation coaxes gcc into prioritising the value==1 + // case, which we expect to be the most common. + // __builtin_expect() didn't have any useful effect (gcc-4.3.0). + if (value == 1) { + return 1; + } else if (value == 0) { + return 0; + } else { + // putting the rest out of line turned out to be a slight + // performance improvement: + return HEAP_ALLOCED_miss(mblock,p); + } +} + +// In the parallel GC, the cache itself is safe to *read*, and can be +// updated atomically, but we need to place a lock around operations +// that touch the MBlock map. +INLINE_HEADER +StgBool HEAP_ALLOCED_GC(void *p) +{ + StgWord mblock; + nat entry_no; + MbcCacheLine entry, value; + StgBool b; + + mblock = (StgWord)p >> MBLOCK_SHIFT; + entry_no = mblock & (MBC_ENTRIES-1); + entry = mblock_cache[entry_no]; + value = entry ^ (mblock << 1); + if (value == 1) { + return 1; + } else if (value == 0) { + return 0; + } else { + // putting the rest out of line turned out to be a slight + // performance improvement: + ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync); + b = HEAP_ALLOCED_miss(mblock,p); + RELEASE_SPIN_LOCK(&gc_alloc_block_sync); + return b; + } +} + +#else +# error HEAP_ALLOCED not defined +#endif + +#include "EndPrivate.h" + +#endif /* SM_HEAP_ALLOC_H */ diff --git a/rts/sm/MBlock.c b/rts/sm/MBlock.c index f626e1f43b..35a11bf589 100644 --- a/rts/sm/MBlock.c +++ b/rts/sm/MBlock.c @@ -23,9 +23,320 @@ W_ mblocks_allocated = 0; W_ mpc_misses = 0; /* ----------------------------------------------------------------------------- - The MBlock Map: provides our implementation of HEAP_ALLOCED() + The MBlock Map: provides our implementation of HEAP_ALLOCED() and the + utilities to walk the really allocated (thus accessible without risk of + segfault) heap -------------------------------------------------------------------------- */ +/* + There are two different cases here: either we use "large address + space" (which really means two-step allocation), so we have to + manage which memory is good (= accessible without fear of segfault) + and which is not owned by us, or we use the older method and get + good memory straight from the system. + + Both code paths need to provide: + + void *getFirstMBlock(void ** state) + return the first (lowest address) mblock + that was actually committed + + void *getNextMBlock(void ** state, void * mblock) + return the first (lowest address) mblock + that was committed, after the given one + + For both these calls, @state is an in-out parameter that points to + an opaque state threading the calls togheter. The calls should only + be used in an interation fashion. Pass NULL if @state is not + interesting,or pass a pointer to NULL if you don't have a state. + + void *getCommittedMBlocks(nat n) + return @n new mblocks, ready to be used (reserved and committed) + + void *decommitMBlocks(char *addr, nat n) + release memory for @n mblocks, starting at the given address + + void releaseFreeMemory() + potentially release any address space that was associated + with recently decommitted blocks +*/ + +#ifdef USE_LARGE_ADDRESS_SPACE + +// Large address space means we use two-step allocation: reserve +// something large upfront, and then commit as needed +// (This is normally only useful on 64-bit, where we can assume +// that reserving 1TB is possible) +// +// There is no block map in this case, but there is a free list +// of blocks that were committed and decommitted at least once, +// which we use to choose which block to commit next in the already +// reserved space. +// +// We cannot let the OS choose it as we do in the +// non large address space case, because the committing wants to +// know the exact address upfront. +// +// The free list is coalesced and ordered, which means that +// allocate and free are worst-case O(n), but benchmarks have shown +// that this is not a significant problem, because large (>=2MB) +// allocations are infrequent and their time is mostly insignificant +// compared to the time to use that memory. +// +// The free list is stored in malloc()'d memory, unlike the other free +// lists in BlockAlloc.c which are stored in block descriptors, +// because we cannot touch the contents of decommitted mblocks. + +typedef struct free_list { + struct free_list *prev; + struct free_list *next; + W_ address; + W_ size; +} free_list; + +static free_list *free_list_head; +static W_ mblock_high_watermark; +W_ mblock_address_space_begin = 0; + +static void *getAllocatedMBlock(free_list **start_iter, W_ startingAt) +{ + free_list *iter; + W_ p = startingAt; + + for (iter = *start_iter; iter != NULL; iter = iter->next) + { + if (p < iter->address) + break; + + if (p == iter->address) + p += iter->size; + } + + *start_iter = iter; + + if (p >= mblock_high_watermark) + return NULL; + + return (void*)p; +} + +void * getFirstMBlock(void **state STG_UNUSED) +{ + free_list *fake_state; + free_list **casted_state; + + if (state) + casted_state = (free_list**)state; + else + casted_state = &fake_state; + + *casted_state = free_list_head; + return getAllocatedMBlock(casted_state, mblock_address_space_begin); +} + +void * getNextMBlock(void **state STG_UNUSED, void *mblock) +{ + free_list *fake_state = free_list_head; + free_list **casted_state; + + if (state) + casted_state = (free_list**)state; + else + casted_state = &fake_state; + + return getAllocatedMBlock(casted_state, (W_)mblock + MBLOCK_SIZE); +} + +static void *getReusableMBlocks(nat n) +{ + struct free_list *iter; + W_ size = MBLOCK_SIZE * (W_)n; + + for (iter = free_list_head; iter != NULL; iter = iter->next) { + void *addr; + + if (iter->size < size) + continue; + + addr = (void*)iter->address; + iter->address += size; + iter->size -= size; + if (iter->size == 0) { + struct free_list *prev, *next; + + prev = iter->prev; + next = iter->next; + if (prev == NULL) { + ASSERT(free_list_head == iter); + free_list_head = next; + } else { + prev->next = next; + } + if (next != NULL) { + next->prev = prev; + } + stgFree(iter); + } + + osCommitMemory(addr, size); + return addr; + } + + return NULL; +} + +static void *getFreshMBlocks(nat n) +{ + W_ size = MBLOCK_SIZE * (W_)n; + void *addr = (void*)mblock_high_watermark; + + if (mblock_high_watermark + size > + mblock_address_space_begin + MBLOCK_SPACE_SIZE) + { + // whoa, 1 TB of heap? + errorBelch("out of memory"); + stg_exit(EXIT_HEAPOVERFLOW); + } + + osCommitMemory(addr, size); + mblock_high_watermark += size; + return addr; +} + +static void *getCommittedMBlocks(nat n) +{ + void *p; + + p = getReusableMBlocks(n); + if (p == NULL) { + p = getFreshMBlocks(n); + } + + ASSERT(p != NULL && p != (void*)-1); + return p; +} + +static void decommitMBlocks(char *addr, nat n) +{ + struct free_list *iter, *prev; + W_ size = MBLOCK_SIZE * (W_)n; + W_ address = (W_)addr; + + osDecommitMemory(addr, size); + + prev = NULL; + for (iter = free_list_head; iter != NULL; iter = iter->next) + { + prev = iter; + + if (iter->address + iter->size < address) + continue; + + if (iter->address + iter->size == address) { + iter->size += size; + + if (address + size == mblock_high_watermark) { + mblock_high_watermark -= iter->size; + if (iter->prev) { + iter->prev->next = NULL; + } else { + ASSERT(iter == free_list_head); + free_list_head = NULL; + } + stgFree(iter); + return; + } + + if (iter->next && + iter->next->address == iter->address + iter->size) { + struct free_list *next; + + next = iter->next; + iter->size += next->size; + iter->next = next->next; + + if (iter->next) { + iter->next->prev = iter; + + /* We don't need to consolidate more */ + ASSERT(iter->next->address > iter->address + iter->size); + } + + stgFree(next); + } + return; + } else if (address + size == iter->address) { + iter->address = address; + iter->size += size; + + /* We don't need to consolidate backwards + (because otherwise it would have been handled by + the previous iteration) */ + if (iter->prev) { + ASSERT(iter->prev->address + iter->prev->size < iter->address); + } + return; + } else { + struct free_list *new_iter; + + /* All other cases have been handled */ + ASSERT(iter->address > address + size); + + new_iter = stgMallocBytes(sizeof(struct free_list), "freeMBlocks"); + new_iter->address = address; + new_iter->size = size; + new_iter->next = iter; + new_iter->prev = iter->prev; + if (new_iter->prev) { + new_iter->prev->next = new_iter; + } else { + ASSERT(iter == free_list_head); + free_list_head = new_iter; + } + iter->prev = new_iter; + return; + } + } + + /* We're past the last free list entry, so we must + be the highest allocation so far + */ + ASSERT(address + size <= mblock_high_watermark); + + /* Fast path the case of releasing high or all memory */ + if (address + size == mblock_high_watermark) { + mblock_high_watermark -= size; + } else { + struct free_list *new_iter; + + new_iter = stgMallocBytes(sizeof(struct free_list), "freeMBlocks"); + new_iter->address = address; + new_iter->size = size; + new_iter->next = NULL; + new_iter->prev = prev; + if (new_iter->prev) { + ASSERT(new_iter->prev->next == NULL); + new_iter->prev->next = new_iter; + } else { + ASSERT(free_list_head == NULL); + free_list_head = new_iter; + } + } +} + +void releaseFreeMemory(void) +{ + // This function exists for releasing address space + // on Windows 32 bit + // + // Do nothing if USE_LARGE_ADDRESS_SPACE, we never want + // to release address space + + debugTrace(DEBUG_gc, "mblock_high_watermark: %p\n", mblock_high_watermark); +} + +#else // !USE_LARGE_ADDRESS_SPACE + #if SIZEOF_VOID_P == 4 StgWord8 mblock_map[MBLOCK_MAP_SIZE]; // initially all zeros @@ -108,6 +419,7 @@ setHeapAlloced(void *p, StgWord8 i) mblock_cache[entry_no] = (mblock << 1) + i; } } + #endif static void @@ -130,7 +442,7 @@ void * mapEntryToMBlock(nat i) return (void *)((StgWord)i << MBLOCK_SHIFT); } -void * getFirstMBlock(void) +void * getFirstMBlock(void **state STG_UNUSED) { nat i; @@ -140,7 +452,7 @@ void * getFirstMBlock(void) return NULL; } -void * getNextMBlock(void *mblock) +void * getNextMBlock(void **state STG_UNUSED, void *mblock) { nat i; @@ -152,7 +464,7 @@ void * getNextMBlock(void *mblock) #elif SIZEOF_VOID_P == 8 -void * getNextMBlock(void *p) +void * getNextMBlock(void **state STG_UNUSED, void *p) { MBlockMap *map; nat off, j; @@ -189,7 +501,7 @@ void * getNextMBlock(void *p) return NULL; } -void * getFirstMBlock(void) +void * getFirstMBlock(void **state STG_UNUSED) { MBlockMap *map = mblock_maps[0]; nat line_no, off; @@ -210,7 +522,38 @@ void * getFirstMBlock(void) return NULL; } -#endif // SIZEOF_VOID_P +#endif // SIZEOF_VOID_P == 8 + +static void *getCommittedMBlocks(nat n) +{ + // The OS layer returns committed memory directly + void *ret = osGetMBlocks(n); + nat i; + + // fill in the table + for (i = 0; i < n; i++) { + markHeapAlloced( (StgWord8*)ret + i * MBLOCK_SIZE ); + } + + return ret; +} + +static void decommitMBlocks(void *p, nat n) +{ + osFreeMBlocks(p, n); + nat i; + + for (i = 0; i < n; i++) { + markHeapUnalloced( (StgWord8*)p + i * MBLOCK_SIZE ); + } +} + +void releaseFreeMemory(void) +{ + osReleaseFreeMemory(); +} + +#endif /* !USE_LARGE_ADDRESS_SPACE */ /* ----------------------------------------------------------------------------- Allocate new mblock(s) @@ -228,18 +571,12 @@ getMBlock(void) void * getMBlocks(nat n) { - nat i; void *ret; - ret = osGetMBlocks(n); + ret = getCommittedMBlocks(n); debugTrace(DEBUG_gc, "allocated %d megablock(s) at %p",n,ret); - // fill in the table - for (i = 0; i < n; i++) { - markHeapAlloced( (StgWord8*)ret + i * MBLOCK_SIZE ); - } - mblocks_allocated += n; peak_mblocks_allocated = stg_max(peak_mblocks_allocated, mblocks_allocated); @@ -249,17 +586,11 @@ getMBlocks(nat n) void freeMBlocks(void *addr, nat n) { - nat i; - debugTrace(DEBUG_gc, "freeing %d megablock(s) at %p",n,addr); mblocks_allocated -= n; - for (i = 0; i < n; i++) { - markHeapUnalloced( (StgWord8*)addr + i * MBLOCK_SIZE ); - } - - osFreeMBlocks(addr, n); + decommitMBlocks(addr, n); } void @@ -267,6 +598,22 @@ freeAllMBlocks(void) { debugTrace(DEBUG_gc, "freeing all megablocks"); +#ifdef USE_LARGE_ADDRESS_SPACE + { + struct free_list *iter, *next; + + for (iter = free_list_head; iter != NULL; iter = next) + { + next = iter->next; + stgFree(iter); + } + } + + osReleaseHeapMemory(); + + mblock_address_space_begin = (W_)-1; + mblock_high_watermark = (W_)-1; +#else osFreeAllMBlocks(); #if SIZEOF_VOID_P == 8 @@ -276,13 +623,23 @@ freeAllMBlocks(void) } stgFree(mblock_maps); #endif + +#endif } void initMBlocks(void) { osMemInit(); -#if SIZEOF_VOID_P == 8 + +#ifdef USE_LARGE_ADDRESS_SPACE + { + void *addr = osReserveHeapMemory(); + + mblock_address_space_begin = (W_)addr; + mblock_high_watermark = (W_)addr; + } +#elif SIZEOF_VOID_P == 8 memset(mblock_cache,0xff,sizeof(mblock_cache)); #endif } diff --git a/rts/sm/OSMem.h b/rts/sm/OSMem.h index db704fc78b..9a6ccdd7ec 100644 --- a/rts/sm/OSMem.h +++ b/rts/sm/OSMem.h @@ -20,6 +20,47 @@ W_ getPageSize (void); StgWord64 getPhysicalMemorySize (void); void setExecutable (void *p, W_ len, rtsBool exec); +#ifdef USE_LARGE_ADDRESS_SPACE + +/* + If "large address space" is enabled, we allocate memory in two + steps: first we request some address space, and then we request some + memory in it. This allows us to ask for much more address space that + we will ever need, which keeps everything nice and consecutive. +*/ + +// Reserve the large address space blob, and return the address that +// the OS has chosen for it. It is not safe to access the memory +// pointed to by the return value, until that memory is committed +// using osCommitMemory(). +// +// This function is called once when the block allocator is initialized. +void *osReserveHeapMemory(void); + +// Commit (allocate memory for) a piece of address space, which must +// be within the previously reserved space After this call, it is safe +// to access @p up to @len bytes. +// +// There is no guarantee on the contents of the memory pointed to by +// @p, in particular it must not be assumed to contain all zeros. +void osCommitMemory(void *p, W_ len); + +// Decommit (release backing memory for) a piece of address space, +// which must be within the previously reserve space and must have +// been previously committed After this call, it is again unsafe to +// access @p (up to @len bytes), but there is no guarantee that the +// memory will be released to the system (as far as eg. RSS statistics +// from top are concerned). +void osDecommitMemory(void *p, W_ len); + +// Release the address space previously obtained and undo the effects of +// osReserveHeapMemory +// +// This function is called once, when the block allocator is deinitialized +// before the program terminates. +void osReleaseHeapMemory(void); +#endif + #include "EndPrivate.h" #endif /* SM_OSMEM_H */ diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index c4a699e59a..e7a8401145 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -637,7 +637,8 @@ checkStaticObjects ( StgClosure* static_objects ) StgClosure *p = static_objects; StgInfoTable *info; - while (p != END_OF_STATIC_LIST) { + while (p != END_OF_STATIC_OBJECT_LIST) { + p = UNTAG_STATIC_LIST_PTR(p); checkClosure(p); info = get_itbl(p); switch (info->type) { diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index a8f0ab037f..dfad0bef58 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -1672,7 +1672,7 @@ scavenge_capability_mut_lists (Capability *cap) static void scavenge_static(void) { - StgClosure* p; + StgClosure *flagged_p, *p; const StgInfoTable *info; debugTrace(DEBUG_gc, "scavenging static objects"); @@ -1690,10 +1690,11 @@ scavenge_static(void) * be more stuff on this list after each evacuation... * (static_objects is a global) */ - p = gct->static_objects; - if (p == END_OF_STATIC_LIST) { + flagged_p = gct->static_objects; + if (flagged_p == END_OF_STATIC_OBJECT_LIST) { break; } + p = UNTAG_STATIC_LIST_PTR(flagged_p); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); info = get_itbl(p); @@ -1708,7 +1709,7 @@ scavenge_static(void) */ gct->static_objects = *STATIC_LINK(info,p); *STATIC_LINK(info,p) = gct->scavenged_static_objects; - gct->scavenged_static_objects = p; + gct->scavenged_static_objects = flagged_p; switch (info -> type) { @@ -2066,7 +2067,7 @@ loop: work_to_do = rtsFalse; // scavenge static objects - if (major_gc && gct->static_objects != END_OF_STATIC_LIST) { + if (major_gc && gct->static_objects != END_OF_STATIC_OBJECT_LIST) { IF_DEBUG(sanity, checkStaticObjects(gct->static_objects)); scavenge_static(); } diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 6e9b0634b7..65f5b70c21 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -175,9 +175,9 @@ initStorage (void) generations[0].max_blocks = 0; - dyn_caf_list = (StgIndStatic*)END_OF_STATIC_LIST; - debug_caf_list = (StgIndStatic*)END_OF_STATIC_LIST; - revertible_caf_list = (StgIndStatic*)END_OF_STATIC_LIST; + dyn_caf_list = (StgIndStatic*)END_OF_CAF_LIST; + debug_caf_list = (StgIndStatic*)END_OF_CAF_LIST; + revertible_caf_list = (StgIndStatic*)END_OF_CAF_LIST; /* initialise the allocate() interface */ large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W; @@ -427,7 +427,7 @@ newCAF(StgRegTable *reg, StgIndStatic *caf) ACQUIRE_SM_LOCK; // dyn_caf_list is global, locked by sm_mutex caf->static_link = (StgClosure*)dyn_caf_list; - dyn_caf_list = caf; + dyn_caf_list = (StgIndStatic*)((StgWord)caf | STATIC_FLAG_LIST); RELEASE_SM_LOCK; } else @@ -484,7 +484,7 @@ StgInd* newRetainedCAF (StgRegTable *reg, StgIndStatic *caf) ACQUIRE_SM_LOCK; caf->static_link = (StgClosure*)revertible_caf_list; - revertible_caf_list = caf; + revertible_caf_list = (StgIndStatic*)((StgWord)caf | STATIC_FLAG_LIST); RELEASE_SM_LOCK; diff --git a/rts/sm/Storage.h b/rts/sm/Storage.h index a4421db3f2..d0094b60fb 100644 --- a/rts/sm/Storage.h +++ b/rts/sm/Storage.h @@ -133,12 +133,59 @@ W_ calcLiveWords (void); extern bdescr *exec_block; -#define END_OF_STATIC_LIST ((StgClosure*)1) - void move_STACK (StgStack *src, StgStack *dest); /* ----------------------------------------------------------------------------- - CAF lists + Note [STATIC_LINK fields] + + The low 2 bits of the static link field have the following meaning: + + 00 we haven't seen this static object before + + 01/10 if it equals static_flag, then we saw it in this GC, otherwise + we saw it in the previous GC. + + 11 ignore during GC. This value is used in two ways + - When we put CAFs on a list (see Note [CAF lists]) + - a static constructor that was determined to have no CAF + references at compile time is given this value, so we + don't traverse it during GC + + This choice of values is quite deliberate, because it means we can + decide whether a static object should be traversed during GC using a + single test: + + bits = link_field & 3; + if ((bits | prev_static_flag) != 3) { ... } + + -------------------------------------------------------------------------- */ + +#define STATIC_BITS 3 + +#define STATIC_FLAG_A 1 +#define STATIC_FLAG_B 2 +#define STATIC_FLAG_LIST 3 + +#define END_OF_CAF_LIST ((StgClosure*)STATIC_FLAG_LIST) + +// The previous and current values of the static flag. These flip +// between STATIC_FLAG_A and STATIC_FLAG_B at each major GC. +extern nat prev_static_flag, static_flag; + +// In the chain of static objects built up during GC, all the link +// fields are tagged with the current static_flag value. How to mark +// the end of the chain? It must be a special value so that we can +// tell it is the end of the chain, but note that we're going to store +// this value in the link field of a static object, which means that +// during the NEXT GC we should treat it like any other object that +// has not been visited during this GC. Therefore, we use static_flag +// as the sentinel value. +#define END_OF_STATIC_OBJECT_LIST ((StgClosure*)(StgWord)static_flag) + +#define UNTAG_STATIC_LIST_PTR(p) ((StgClosure*)((StgWord)(p) & ~STATIC_BITS)) + +/* ----------------------------------------------------------------------------- + Note [CAF lists] dyn_caf_list (CAFs chained through static_link) This is a chain of all CAFs in the program, used for @@ -154,6 +201,10 @@ void move_STACK (StgStack *src, StgStack *dest); A chain of CAFs in object code loaded with the RTS linker. These CAFs can be reverted to their unevaluated state using revertCAFs. + + Pointers in these lists are tagged with STATIC_FLAG_LIST, so when + traversing the list remember to untag each pointer with + UNTAG_STATIC_LIST_PTR(). --------------------------------------------------------------------------- */ extern StgIndStatic * dyn_caf_list; diff --git a/rts/win32/OSMem.c b/rts/win32/OSMem.c index afa5113638..716171b3fc 100644 --- a/rts/win32/OSMem.c +++ b/rts/win32/OSMem.c @@ -8,6 +8,7 @@ #include "Rts.h" #include "sm/OSMem.h" +#include "sm/HeapAlloc.h" #include "RtsUtils.h" #if HAVE_WINDOWS_H @@ -28,7 +29,11 @@ typedef struct block_rec_ { /* allocs are kept in ascending order, and are the memory regions as returned by the OS as we need to have matching VirtualAlloc and - VirtualFree calls. */ + VirtualFree calls. + + If USE_LARGE_ADDRESS_SPACE is defined, this list will contain only + one element. +*/ static alloc_rec* allocs = NULL; /* free_blocks are kept in ascending order, and adjacent blocks are merged */ @@ -207,12 +212,9 @@ osGetMBlocks(nat n) { return ret; } -void osFreeMBlocks(char *addr, nat n) +static void decommitBlocks(char *addr, W_ nBytes) { alloc_rec *p; - W_ nBytes = (W_)n * MBLOCK_SIZE; - - insertFree(addr, nBytes); p = allocs; while ((p != NULL) && (addr >= (p->base + p->size))) { @@ -243,6 +245,14 @@ void osFreeMBlocks(char *addr, nat n) } } +void osFreeMBlocks(char *addr, nat n) +{ + W_ nBytes = (W_)n * MBLOCK_SIZE; + + insertFree(addr, nBytes); + decommitBlocks(addr, nBytes); +} + void osReleaseFreeMemory(void) { alloc_rec *prev_a, *a; @@ -414,3 +424,60 @@ void setExecutable (void *p, W_ len, rtsBool exec) stg_exit(EXIT_FAILURE); } } + +#ifdef USE_LARGE_ADDRESS_SPACE + +static void* heap_base = NULL; + +void *osReserveHeapMemory (void) +{ + void *start; + + heap_base = VirtualAlloc(NULL, MBLOCK_SPACE_SIZE + MBLOCK_SIZE, + MEM_RESERVE, PAGE_READWRITE); + if (heap_base == NULL) { + if (GetLastError() == ERROR_NOT_ENOUGH_MEMORY) { + errorBelch("out of memory"); + } else { + sysErrorBelch( + "osReserveHeapMemory: VirtualAlloc MEM_RESERVE %llu bytes failed", + MBLOCK_SPACE_SIZE + MBLOCK_SIZE); + } + stg_exit(EXIT_FAILURE); + } + + // VirtualFree MEM_RELEASE must always match a + // previous MEM_RESERVE call, in address and size + // so we necessarily leak some address space here, + // before and after the aligned area + // It is not a huge problem because we never commit + // that memory + start = MBLOCK_ROUND_UP(heap_base); + + return start; +} + +void osCommitMemory (void *at, W_ size) +{ + void *temp; + temp = VirtualAlloc(at, size, MEM_COMMIT, PAGE_READWRITE); + if (temp == NULL) { + sysErrorBelch("osCommitMemory: VirtualAlloc MEM_COMMIT failed"); + stg_exit(EXIT_FAILURE); + } +} + +void osDecommitMemory (void *at, W_ size) +{ + if (!VirtualFree(at, size, MEM_DECOMMIT)) { + sysErrorBelch("osDecommitMemory: VirtualFree MEM_DECOMMIT failed"); + stg_exit(EXIT_FAILURE); + } +} + +void osReleaseHeapMemory (void) +{ + VirtualFree(heap_base, 0, MEM_RELEASE); +} + +#endif diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 3583a062af..6ebb05a90e 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -55,9 +55,8 @@ tmp.d *.so *bindisttest_install___dir_bin_ghc.mk *bindisttest_install___dir_bin_ghc.exe.mk -mk/ghcconfig*_inplace_bin_ghc-stage1.mk -mk/ghcconfig*_inplace_bin_ghc-stage2.mk -mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk +mk/ghcconfig*_bin_ghc-*.mk +mk/ghcconfig*_bin_ghc-*.exe.mk *.imports # ----------------------------------------------------------------------------- @@ -119,6 +118,12 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk /tests/cabal/sigcabal01/p_lazy /tests/cabal/sigcabal01/p_strict /tests/cabal/sigcabal01/containers +/tests/cabal/sigcabal02/Main +/tests/cabal/sigcabal02/p_ipid +/tests/cabal/sigcabal02/q_ipid +/tests/cabal/sigcabal02/containers +/tests/cabal/sigcabal02/tmp* +/tests/cabal/sigcabal02/inst* /tests/cabal/local01.package.conf/ /tests/cabal/local03.package.conf/ /tests/cabal/local04.package.conf/ diff --git a/testsuite/tests/annotations/should_run/Makefile b/testsuite/tests/annotations/should_run/Makefile index 71e065f76b..49339a5d1e 100644 --- a/testsuite/tests/annotations/should_run/Makefile +++ b/testsuite/tests/annotations/should_run/Makefile @@ -6,7 +6,6 @@ CONFIG_HS=Config.hs config : rm -f $(CONFIG_HS) - @echo "Creating $(CONFIG_HS) ... " echo "module Config where" >>$(CONFIG_HS) echo "cTop :: String" >> $(CONFIG_HS) echo 'cTop = "$(subst \,\\,$(shell '$(TEST_HC)' --print-libdir))"' >> $(CONFIG_HS) diff --git a/testsuite/tests/cabal/sigcabal01/Makefile b/testsuite/tests/cabal/sigcabal01/Makefile index c284842bdd..73cffd7a68 100644 --- a/testsuite/tests/cabal/sigcabal01/Makefile +++ b/testsuite/tests/cabal/sigcabal01/Makefile @@ -22,7 +22,7 @@ sigcabal01: cd p && $(SETUP) build cd p && $(SETUP) copy cd p && $(SETUP) register --print-ipid > ../p_strict - '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package-id "`cat p_lazy` (P as P.Lazy)" -package-id "`cat p_strict` (P as P.Strict)" --make Main.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package containers -package-id "`cat p_lazy` (P as P.Lazy)" -package-id "`cat p_strict` (P as P.Strict)" --make Main.hs ! ./Main ifneq "$(CLEANUP)" "" $(MAKE) clean diff --git a/testsuite/tests/cabal/sigcabal01/all.T b/testsuite/tests/cabal/sigcabal01/all.T index a797c0890d..24c50b672a 100644 --- a/testsuite/tests/cabal/sigcabal01/all.T +++ b/testsuite/tests/cabal/sigcabal01/all.T @@ -4,6 +4,6 @@ else: cleanup = '' test('sigcabal01', - normal, + expect_broken(10622), run_command, ['$MAKE -s --no-print-directory sigcabal01 ' + cleanup]) diff --git a/testsuite/tests/cabal/sigcabal02/Main.hs b/testsuite/tests/cabal/sigcabal02/Main.hs new file mode 100644 index 0000000000..52def3d41f --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/Main.hs @@ -0,0 +1,7 @@ +import Map +import P +import Q + +main = do + x <- foo + print (mymember 5 x) diff --git a/testsuite/tests/cabal/sigcabal02/Makefile b/testsuite/tests/cabal/sigcabal02/Makefile new file mode 100644 index 0000000000..c45697d1b6 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/Makefile @@ -0,0 +1,34 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP=../Setup -v0 + +# This test is for two Cabal packages exposing the same signature + +sigcabal02: + $(MAKE) clean + '$(GHC_PKG)' field containers id | sed 's/^.*: *//' > containers + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' -v0 --make Setup + cd p && $(SETUP) clean + cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-p' --instantiate-with="Map=Data.Map.Lazy@`cat ../containers`" --instantiate-with="Set=Data.Set@`cat ../containers`" --ghc-pkg-options="--enable-multi-instance" + cd p && $(SETUP) build + cd p && $(SETUP) copy + cd p && $(SETUP) register --print-ipid > ../p_ipid + cd q && $(SETUP) clean + cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-p' --instantiate-with="Map=Data.Map.Lazy@`cat ../containers`" --ghc-pkg-options="--enable-multi-instance" + cd q && $(SETUP) build + cd q && $(SETUP) copy + cd q && $(SETUP) register --print-ipid > ../q_ipid + '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package containers -package-id "`cat p_ipid`" -package-id "`cat q_ipid`" --make Main.hs + ./Main + ! '$(TEST_HC)' $(TEST_HC_OPTS) -package-db=tmp.d -hide-all-packages -package base -package containers -package-id "`cat p_ipid`" -package-id "`cat q_ipid`" --make ShouldFail.hs +ifneq "$(CLEANUP)" "" + $(MAKE) clean +endif + +clean : + '$(GHC_PKG)' unregister --force p >/dev/null 2>&1 || true + '$(GHC_PKG)' unregister --force q >/dev/null 2>&1 || true + $(RM) -r tmp.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) diff --git a/testsuite/tests/cabal/sigcabal02/Setup.hs b/testsuite/tests/cabal/sigcabal02/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/sigcabal02/ShouldFail.hs b/testsuite/tests/cabal/sigcabal02/ShouldFail.hs new file mode 100644 index 0000000000..98ec49e886 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/ShouldFail.hs @@ -0,0 +1 @@ +import Set diff --git a/testsuite/tests/cabal/sigcabal02/all.T b/testsuite/tests/cabal/sigcabal02/all.T new file mode 100644 index 0000000000..11eb05975b --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/all.T @@ -0,0 +1,9 @@ +if default_testopts.cleanup != '': + cleanup = 'CLEANUP=1' +else: + cleanup = '' + +test('sigcabal02', + normal, + run_command, + ['$MAKE -s --no-print-directory sigcabal02 ' + cleanup]) diff --git a/testsuite/tests/cabal/sigcabal02/p/LICENSE b/testsuite/tests/cabal/sigcabal02/p/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/p/LICENSE diff --git a/testsuite/tests/cabal/sigcabal02/p/Map.hsig b/testsuite/tests/cabal/sigcabal02/p/Map.hsig new file mode 100644 index 0000000000..359cf64ab9 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/p/Map.hsig @@ -0,0 +1,18 @@ +{-# LANGUAGE RoleAnnotations #-} +module Map where + +import Set + +type role Map nominal representational +data Map k a + +instance (Show k, Show a) => Show (Map k a) + +size :: Map k a -> Int +lookup :: Ord k => k -> Map k a -> Maybe a +empty :: Map k a +insert :: Ord k => k -> a -> Map k a -> Map k a +delete :: Ord k => k -> Map k a -> Map k a + +keysSet :: Map k a -> Set k +fromSet :: (k -> a) -> Set k -> Map k a diff --git a/testsuite/tests/cabal/sigcabal02/p/P.hs b/testsuite/tests/cabal/sigcabal02/p/P.hs new file mode 100644 index 0000000000..dec6b41c94 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/p/P.hs @@ -0,0 +1,12 @@ +module P where + +import qualified Map +import qualified Set + +foo = do + let x = Map.insert 0 "foo" + . Map.insert (6 :: Int) "foo" + $ Map.empty + print (Map.lookup 1 x) + print (Set.size (Map.keysSet x)) + return x diff --git a/testsuite/tests/cabal/sigcabal02/p/Set.hsig b/testsuite/tests/cabal/sigcabal02/p/Set.hsig new file mode 100644 index 0000000000..1713133365 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/p/Set.hsig @@ -0,0 +1,13 @@ +{-# LANGUAGE RoleAnnotations #-} +module Set where + +type role Set nominal +data Set a + +instance Show a => Show (Set a) + +size :: Set a -> Int +member :: Ord a => a -> Set a -> Bool +empty :: Set a +insert :: Ord a => a -> Set a -> Set a +delete :: Ord a => a -> Set a -> Set a diff --git a/testsuite/tests/cabal/sigcabal02/p/p.cabal b/testsuite/tests/cabal/sigcabal02/p/p.cabal new file mode 100644 index 0000000000..bb3b2a4463 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/p/p.cabal @@ -0,0 +1,14 @@ +name: p +version: 1.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.20 + +library + exposed-modules: P + exposed-signatures: Map + required-signatures: Set + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/cabal/sigcabal02/q/LICENSE b/testsuite/tests/cabal/sigcabal02/q/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/q/LICENSE diff --git a/testsuite/tests/cabal/sigcabal02/q/Map.hsig b/testsuite/tests/cabal/sigcabal02/q/Map.hsig new file mode 100644 index 0000000000..40fd0bc74c --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/q/Map.hsig @@ -0,0 +1,7 @@ +{-# LANGUAGE RoleAnnotations #-} +module Map where + +type role Map nominal representational +data Map k a + +member :: Ord k => k -> Map k a -> Bool diff --git a/testsuite/tests/cabal/sigcabal02/q/Q.hs b/testsuite/tests/cabal/sigcabal02/q/Q.hs new file mode 100644 index 0000000000..ba55fb97b7 --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/q/Q.hs @@ -0,0 +1,7 @@ +module Q where + +import qualified Map +import Map(Map) + +mymember :: Int -> Map Int a -> Bool +mymember k m = Map.member k m || Map.member (k + 1) m diff --git a/testsuite/tests/cabal/sigcabal02/q/q.cabal b/testsuite/tests/cabal/sigcabal02/q/q.cabal new file mode 100644 index 0000000000..2f99c4403c --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/q/q.cabal @@ -0,0 +1,13 @@ +name: q +version: 1.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.20 + +library + exposed-modules: Q + exposed-signatures: Map + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr b/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr new file mode 100644 index 0000000000..7c1f09239f --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/sigcabal02.stderr @@ -0,0 +1,4 @@ + +ShouldFail.hs:1:8: + Could not find module ‘Set’ + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout b/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout new file mode 100644 index 0000000000..48cb59e63a --- /dev/null +++ b/testsuite/tests/cabal/sigcabal02/sigcabal02.stdout @@ -0,0 +1,5 @@ +[1 of 1] Compiling Main ( Main.hs, Main.o ) +Linking Main ... +Nothing +2 +True diff --git a/testsuite/tests/concurrent/prog002/Thread.hs b/testsuite/tests/concurrent/prog002/Thread.hs index 9e342ac977..301e8441b6 100644 --- a/testsuite/tests/concurrent/prog002/Thread.hs +++ b/testsuite/tests/concurrent/prog002/Thread.hs @@ -14,6 +14,13 @@ data ThreadTree req rsp m = ---------------------------------- newtype ContM req rsp m a = ContM ((a-> ThreadTree req rsp m)-> ThreadTree req rsp m) +instance Functor (ContM req rsp m) where + fmap = undefined + +instance Applicative (ContM req rsp m) where + pure = undefined + (<*>) = undefined + instance Monad m => Monad (ContM req rsp m) where m >>= f = contmBind m f return = contmReturn diff --git a/testsuite/tests/concurrent/prog002/all.T b/testsuite/tests/concurrent/prog002/all.T index 54613a7e4a..5eb62382ee 100644 --- a/testsuite/tests/concurrent/prog002/all.T +++ b/testsuite/tests/concurrent/prog002/all.T @@ -11,6 +11,7 @@ else: test('concprog002', [only_ways(['threaded2','threaded2_hT']), + expect_broken_for(10661, ['threaded2_hT']), extra_ways(ways), exit_code(1), when(fast(), skip), diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 7fe4b3caa5..80734adaf0 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -174,7 +174,8 @@ test('conc033', normal, compile_and_run, ['']) # Omit for GHCi, because it just sits there waiting for you to press ^C test('conc034', [ - omit_ways(['ghci']), + normal, + omit_ways(['ghci']), extra_run_opts('+RTS -C0 -RTS')], compile_and_run, ['']) diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 607ecc1b24..cd14bd1754 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -2,6 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 8, types: 19, coercions: 1} +-- RHS size: {terms: 2, types: 3, coercions: 1} T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a [GblId[DataConWrapper], Caf=NoCafRefs, @@ -9,9 +10,10 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=False) - Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N}] -T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N + Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a)}] +T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a) +-- RHS size: {terms: 4, types: 7, coercions: 0} absurd :: forall a. Int :~: Bool -> a [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>b] absurd = \ (@ a) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { } diff --git a/testsuite/tests/deriving/should_run/T10447.hs b/testsuite/tests/deriving/should_run/T10447.hs new file mode 100644 index 0000000000..e91ce98f64 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T10447.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-} +module Main where + +class (a ~ Int) => Foo a +instance Foo Int + +data A a where + A1 :: Ord a => a -> A a + A2 :: Int -> A Int + A3 :: b ~ Int => b -> A Int + A4 :: a ~ Int => Int -> A a + A5 :: a ~ Int => a -> A a + A6 :: (a ~ b, b ~ Int) => Int -> b -> A a + A7 :: Foo a => Int -> a -> A a + +deriving instance Foldable A + +data HK f a where + HK1 :: f a -> HK f (f a) + HK2 :: f a -> HK f a + +deriving instance Foldable f => Foldable (HK f) + +one :: Int +one = 1 + +main :: IO () +main = do + mapM_ (print . foldr (+) one) + [ A1 one + , A2 one + , A3 one + , A4 one + , A5 one + , A6 one one + , A7 one one + ] + mapM_ (print . foldr mappend Nothing) + [ HK1 (Just "Hello") + , HK2 (Just (Just "World")) + ] diff --git a/testsuite/tests/deriving/should_run/T10447.stdout b/testsuite/tests/deriving/should_run/T10447.stdout new file mode 100644 index 0000000000..079b327601 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T10447.stdout @@ -0,0 +1,9 @@ +2 +1 +1 +1 +2 +1 +2 +Nothing +Just "World" diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T index 1ccbdd77f8..d47e5c1312 100644 --- a/testsuite/tests/deriving/should_run/all.T +++ b/testsuite/tests/deriving/should_run/all.T @@ -39,3 +39,4 @@ test('T7931', normal, compile_and_run, ['']) test('T9576', exit_code(1), compile_and_run, ['']) test('T9830', extra_clean(['T9830a.hi', 'T9830a.o']), multimod_compile_and_run, ['T9830','-v0']) test('T10104', normal, compile_and_run, ['']) +test('T10447', normal, compile_and_run, ['']) diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo005/A005.hsig b/testsuite/tests/driver/dynamicToo/dynamicToo005/A005.hsig new file mode 100644 index 0000000000..75d621cfec --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo005/A005.hsig @@ -0,0 +1,5 @@ + +module A005 where + +data Maybe a = Nothing | Just a + diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile b/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile new file mode 100644 index 0000000000..617510eec4 --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile @@ -0,0 +1,16 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +checkExists = [ -f $1 ] || echo $1 missing + +.PHONY: dynamicToo005 +# Check that "-c -dynamic-too" works with .hsig +dynamicToo005: + "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 \ + -sig-of A005=base:Prelude \ + -c A005.hsig + $(call checkExists,A005.o) + $(call checkExists,A005.hi) + $(call checkExists,A005.dyn_o) + $(call checkExists,A005.dyn_hi) diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo005/test.T b/testsuite/tests/driver/dynamicToo/dynamicToo005/test.T new file mode 100644 index 0000000000..48460f5135 --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo005/test.T @@ -0,0 +1,8 @@ + +test('dynamicToo005', + [extra_clean(['A005.o', 'A005.hi', 'A005.dyn_o', 'A005.dyn_hi']), + unless(have_vanilla(), skip), + unless(have_dynamic(), skip)], + run_command, + ['$MAKE -s --no-print-directory dynamicToo005']) + diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig b/testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig new file mode 100644 index 0000000000..f79d5d334f --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig @@ -0,0 +1,5 @@ + +module A where + +data Maybe a = Nothing | Just a + diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs b/testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs new file mode 100644 index 0000000000..65900e786a --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module B where + +import A + +b :: Maybe a +b = Nothing diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile b/testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile new file mode 100644 index 0000000000..497f2c0942 --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile @@ -0,0 +1,20 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +checkExists = [ -f $1 ] || echo $1 missing + +.PHONY: dynamicToo006 +# Check that "--make -dynamic-too" works with .hsig +dynamicToo006: + "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 \ + -sig-of A=base:Prelude \ + --make B + $(call checkExists,A.o) + $(call checkExists,B.o) + $(call checkExists,A.hi) + $(call checkExists,B.hi) + $(call checkExists,A.dyn_o) + $(call checkExists,B.dyn_o) + $(call checkExists,A.dyn_hi) + $(call checkExists,B.dyn_hi) diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/test.T b/testsuite/tests/driver/dynamicToo/dynamicToo006/test.T new file mode 100644 index 0000000000..72e06ca524 --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/dynamicToo006/test.T @@ -0,0 +1,9 @@ + +test('dynamicToo006', + [extra_clean(['A.o', 'A.hi', 'A.dyn_o', 'A.dyn_hi', + 'B.o', 'B.hi', 'B.dyn_o', 'B.dyn_hi']), + unless(have_vanilla(), skip), + unless(have_dynamic(), skip)], + run_command, + ['$MAKE -s --no-print-directory dynamicToo006']) + diff --git a/testsuite/tests/driver/recomp014/Makefile b/testsuite/tests/driver/recomp014/Makefile new file mode 100644 index 0000000000..e788110097 --- /dev/null +++ b/testsuite/tests/driver/recomp014/Makefile @@ -0,0 +1,31 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# -fforce-recomp makes lots of driver tests trivially pass, so we +# filter it out from $(TEST_HC_OPTS). +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +# Recompilation tests + +clean: + rm -f *.o *.hi + +recomp014: clean + echo 'module A where a = False' > A.hs + echo 'module A1 where a = False' > A1.hs + echo 'module B where a :: Bool' > B.hsig + echo 'first run' + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c A1.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of "B is main:A" + echo 'import B; main = print a' > C.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs + echo 'second run' + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c B.hsig -sig-of "B is main:A1" + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -c C.hs + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A1.o C.o -o recomp014 + ./recomp014 + +.PHONY: clean recomp014 diff --git a/testsuite/tests/driver/recomp014/all.T b/testsuite/tests/driver/recomp014/all.T new file mode 100644 index 0000000000..affccd2f7f --- /dev/null +++ b/testsuite/tests/driver/recomp014/all.T @@ -0,0 +1,4 @@ +test('recomp014', + [ clean_cmd('$MAKE -s clean') ], + run_command, + ['$MAKE -s --no-print-directory recomp014']) diff --git a/testsuite/tests/driver/recomp014/recomp014.stdout b/testsuite/tests/driver/recomp014/recomp014.stdout new file mode 100644 index 0000000000..7d540716f0 --- /dev/null +++ b/testsuite/tests/driver/recomp014/recomp014.stdout @@ -0,0 +1,4 @@ +first run +compilation IS NOT required +second run +False diff --git a/testsuite/tests/driver/sigof01/Makefile b/testsuite/tests/driver/sigof01/Makefile index 84dfc33a9f..629d4b656a 100644 --- a/testsuite/tests/driver/sigof01/Makefile +++ b/testsuite/tests/driver/sigof01/Makefile @@ -21,3 +21,9 @@ sigof01m: mkdir tmp_sigof01m '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -outputdir tmp_sigof01m --make Main.hs -sig-of "B is main:A" -o tmp_sigof01m/Main tmp_sigof01m/Main + +sigof01i: + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) --interactive -v0 -ignore-dot-ghci Main.hs -sig-of "B is main:A" < sigof01i.script + +sigof01i2: + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) --interactive -v0 -ignore-dot-ghci -sig-of "B is main:A" < sigof01i2.script diff --git a/testsuite/tests/driver/sigof01/all.T b/testsuite/tests/driver/sigof01/all.T index d0cdc3c02c..50418b9af0 100644 --- a/testsuite/tests/driver/sigof01/all.T +++ b/testsuite/tests/driver/sigof01/all.T @@ -7,3 +7,13 @@ test('sigof01m', [ clean_cmd('rm -rf tmp_sigof01m') ], run_command, ['$MAKE -s --no-print-directory sigof01m']) + +test('sigof01i', + normal, + run_command, + ['$MAKE -s --no-print-directory sigof01i']) + +test('sigof01i2', + normal, + run_command, + ['$MAKE -s --no-print-directory sigof01i2']) diff --git a/testsuite/tests/driver/sigof01/sigof01i.script b/testsuite/tests/driver/sigof01/sigof01i.script new file mode 100644 index 0000000000..ba2906d066 --- /dev/null +++ b/testsuite/tests/driver/sigof01/sigof01i.script @@ -0,0 +1 @@ +main diff --git a/testsuite/tests/driver/sigof01/sigof01i.stdout b/testsuite/tests/driver/sigof01/sigof01i.stdout new file mode 100644 index 0000000000..bb614cd2a0 --- /dev/null +++ b/testsuite/tests/driver/sigof01/sigof01i.stdout @@ -0,0 +1,3 @@ +False +T +True diff --git a/testsuite/tests/driver/sigof01/sigof01i2.script b/testsuite/tests/driver/sigof01/sigof01i2.script new file mode 100644 index 0000000000..3a91e377a3 --- /dev/null +++ b/testsuite/tests/driver/sigof01/sigof01i2.script @@ -0,0 +1,3 @@ +:load B +:browse B +:issafe diff --git a/testsuite/tests/driver/sigof01/sigof01i2.stdout b/testsuite/tests/driver/sigof01/sigof01i2.stdout new file mode 100644 index 0000000000..ac15dcfa1e --- /dev/null +++ b/testsuite/tests/driver/sigof01/sigof01i2.stdout @@ -0,0 +1,8 @@ +class Foo a where + foo :: a -> a +data T = A.T +mkT :: T +x :: Bool +Trust type is (Module: Safe, Package: trusted) +Package Trust: Off +B is trusted! diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T index 9a48e69894..f458553116 100644 --- a/testsuite/tests/gadt/all.T +++ b/testsuite/tests/gadt/all.T @@ -70,7 +70,7 @@ test('karl2', normal, compile, ['']) test('data1', normal, compile, ['']) test('data2', normal, compile, ['']) -test('termination', normal, compile, ['']) +test('termination', expect_broken_for(10658, ['optasm', 'optllvm']), compile, ['']) test('set', normal, compile, ['']) test('scoped', normal, compile, ['']) test('gadt-escape1', normal, compile_fail, ['']) diff --git a/testsuite/tests/ghc-e/Makefile b/testsuite/tests/ghc-e/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/ghc-e/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stderr b/testsuite/tests/ghci.debugger/scripts/break003.stderr index 00d4237e49..bf3d2ef5a4 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break003.stderr @@ -1,5 +1,5 @@ -<interactive>:5:1: error: +<interactive>:4:1: error: No instance for (Show (t -> t1)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 8a90905260..9822dd785b 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -1,9 +1,9 @@ -<interactive>:6:1:
+<interactive>:5:1:
No instance for (Show t1) arising from a use of ‘print’
Cannot resolve unknown runtime type ‘t1’
Use :print or :force to determine these types
- Relevant bindings include it :: t1 (bound at <interactive>:6:1)
+ Relevant bindings include it :: t1 (bound at <interactive>:5:1)
Note: there are several potential instances:
instance (Show a, Show b) => Show (Either a b)
-- Defined in ‘Data.Either’
@@ -15,11 +15,11 @@ ...plus 33 others
In a stmt of an interactive GHCi command: print it
-<interactive>:8:1:
+<interactive>:7:1:
No instance for (Show t1) arising from a use of ‘print’
Cannot resolve unknown runtime type ‘t1’
Use :print or :force to determine these types
- Relevant bindings include it :: t1 (bound at <interactive>:8:1)
+ Relevant bindings include it :: t1 (bound at <interactive>:7:1)
Note: there are several potential instances:
instance (Show a, Show b) => Show (Either a b)
-- Defined in ‘Data.Either’
diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index 0c92dba4e4..15c9f839db 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -1,9 +1,9 @@ -<interactive>:11:1: +<interactive>:10:1: No instance for (Show a1) arising from a use of ‘print’ Cannot resolve unknown runtime type ‘a1’ Use :print or :force to determine these types - Relevant bindings include it :: a1 (bound at <interactive>:11:1) + Relevant bindings include it :: a1 (bound at <interactive>:10:1) Note: there are several potential instances: instance Show TyCon -- Defined in ‘Data.Typeable.Internal’ instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’ diff --git a/testsuite/tests/ghci/prog009/ghci.prog009.stderr b/testsuite/tests/ghci/prog009/ghci.prog009.stderr index 2ad634d746..b2072f6413 100644 --- a/testsuite/tests/ghci/prog009/ghci.prog009.stderr +++ b/testsuite/tests/ghci/prog009/ghci.prog009.stderr @@ -1,7 +1,7 @@ A.hs:1:16: error: parse error on input ‘where’
-<interactive>:26:1: error:
+<interactive>:25:1: error:
Variable not in scope: yan
Perhaps you meant ‘tan’ (imported from Prelude)
diff --git a/testsuite/tests/ghci/prog013/prog013.stderr b/testsuite/tests/ghci/prog013/prog013.stderr index ce8827f6ca..a1b5651c9e 100644 --- a/testsuite/tests/ghci/prog013/prog013.stderr +++ b/testsuite/tests/ghci/prog013/prog013.stderr @@ -8,7 +8,7 @@ Bad.hs:3:8: error: Bad.hs:3:8: error: lexical error in string/character literal at character '\n' -<interactive>:10:1: error: parse error on input ‘+’ +<interactive>:9:1: error: parse error on input ‘+’ Bad.hs:3:8: error: lexical error in string/character literal at character '\n' diff --git a/testsuite/tests/ghci/scripts/Defer02.stderr b/testsuite/tests/ghci/scripts/Defer02.stderr index b5b3373489..4a92236b38 100644 --- a/testsuite/tests/ghci/scripts/Defer02.stderr +++ b/testsuite/tests/ghci/scripts/Defer02.stderr @@ -128,7 +128,7 @@ In an equation for ‘b’: b x = x == x (deferred type error) -<interactive>:8:11: error: +<interactive>:7:11: error: Couldn't match type ‘Bool’ with ‘Int’ Expected type: C Int Actual type: C Bool @@ -175,7 +175,7 @@ In an equation for ‘j’: j = myOp 23 (deferred type error) -<interactive>:14:8: error: +<interactive>:13:8: error: Couldn't match expected type ‘Bool’ with actual type ‘Int’ In the first argument of ‘print’, namely ‘(k 2)’ In the expression: print (k 2) diff --git a/testsuite/tests/ghci/scripts/T10018.script b/testsuite/tests/ghci/scripts/T10018.script new file mode 100644 index 0000000000..f346899f4d --- /dev/null +++ b/testsuite/tests/ghci/scripts/T10018.script @@ -0,0 +1,3 @@ +-- Declaring a custom fixity for an infix data constructor should work. +data Infix a b = a :@: b; infixl 4 :@: +:i (:@:) diff --git a/testsuite/tests/ghci/scripts/T10018.stdout b/testsuite/tests/ghci/scripts/T10018.stdout new file mode 100644 index 0000000000..4f7d4807b2 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T10018.stdout @@ -0,0 +1,2 @@ +data Infix a b = a :@: b -- Defined at <interactive>:2:18 +infixl 4 :@: diff --git a/testsuite/tests/ghci/scripts/T10248.stderr b/testsuite/tests/ghci/scripts/T10248.stderr index b54412ebc8..59b0b29078 100644 --- a/testsuite/tests/ghci/scripts/T10248.stderr +++ b/testsuite/tests/ghci/scripts/T10248.stderr @@ -1,12 +1,12 @@ -<interactive>:3:10: warning:
+<interactive>:2:10: warning:
Found hole: _ :: IO ()
In the second argument of ‘(<$>)’, namely ‘_’
In the first argument of ‘ghciStepIO :: IO a -> IO a’, namely
‘Just <$> _’
In a stmt of an interactive GHCi command:
it <- ghciStepIO :: IO a -> IO a (Just <$> _)
-*** Exception: <interactive>:3:10: error:
+*** Exception: <interactive>:2:10: error:
Found hole: _ :: IO ()
In the second argument of ‘(<$>)’, namely ‘_’
In the first argument of ‘ghciStepIO :: IO a -> IO a’, namely
diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stderr b/testsuite/tests/ghci/scripts/T2182ghci.stderr index 470e72945d..f5eafdfc88 100644 --- a/testsuite/tests/ghci/scripts/T2182ghci.stderr +++ b/testsuite/tests/ghci/scripts/T2182ghci.stderr @@ -1,25 +1,25 @@ -<interactive>:3:1: error: +<interactive>:2:1: error: No instance for (Show (t0 -> t0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it -<interactive>:11:1: error: +<interactive>:10:1: error: No instance for (Show (t0 -> t0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it -<interactive>:20:1: error: +<interactive>:19:1: error: No instance for (Show (t0 -> t0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it -<interactive>:29:1: error: +<interactive>:28:1: error: No instance for (Show (t0 -> t0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it -<interactive>:50:1: error: +<interactive>:49:1: error: No instance for (Show (t0 -> t0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.stderr b/testsuite/tests/ghci/scripts/T2182ghci2.stderr index f850e1d7b4..fde88e3c8a 100644 --- a/testsuite/tests/ghci/scripts/T2182ghci2.stderr +++ b/testsuite/tests/ghci/scripts/T2182ghci2.stderr @@ -1,8 +1,8 @@ -<interactive>:8:1:
+<interactive>:7:1:
No instance for (Show Float) arising from a use of ‘print’
In a stmt of an interactive GHCi command: print it
-<interactive>:16:1:
+<interactive>:15:1:
No instance for (Show Float) arising from a use of ‘print’
In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci/scripts/T2816.stderr b/testsuite/tests/ghci/scripts/T2816.stderr index 69d8349778..bc9fa44254 100644 --- a/testsuite/tests/ghci/scripts/T2816.stderr +++ b/testsuite/tests/ghci/scripts/T2816.stderr @@ -1,2 +1,2 @@ -<interactive>:2:1: error: Variable not in scope: α
+<interactive>:1:1: error: Variable not in scope: α
diff --git a/testsuite/tests/ghci/scripts/T4127a.stderr b/testsuite/tests/ghci/scripts/T4127a.stderr index 58d1bb683e..829ae2f8ca 100644 --- a/testsuite/tests/ghci/scripts/T4127a.stderr +++ b/testsuite/tests/ghci/scripts/T4127a.stderr @@ -1,8 +1,8 @@ -<interactive>:3:68: +<interactive>:2:68: Multiple declarations of ‘f’ - Declared at: <interactive>:3:32 - <interactive>:3:68 + Declared at: <interactive>:2:32 + <interactive>:2:68 In the Template Haskell quotation [d| f = undefined class Foo x where diff --git a/testsuite/tests/ghci/scripts/T5564.stderr b/testsuite/tests/ghci/scripts/T5564.stderr index 309ff1e76c..a63bcc8a95 100644 --- a/testsuite/tests/ghci/scripts/T5564.stderr +++ b/testsuite/tests/ghci/scripts/T5564.stderr @@ -1,10 +1,10 @@ -<interactive>:3:1: error:
+<interactive>:2:1: error:
Variable not in scope: git
- Perhaps you meant ‘it’ (line 2)
+ Perhaps you meant ‘it’ (line 1)
-<interactive>:5:1: error:
+<interactive>:4:1: error:
Variable not in scope: fit
Perhaps you meant one of these:
‘fst’ (imported from Prelude), ‘Ghci1.it’ (imported from Ghci1),
- ‘it’ (line 4)
+ ‘it’ (line 3)
diff --git a/testsuite/tests/ghci/scripts/T6027ghci.stdout b/testsuite/tests/ghci/scripts/T6027ghci.stdout index 2cc6934ea7..be1034b0c7 100644 --- a/testsuite/tests/ghci/scripts/T6027ghci.stdout +++ b/testsuite/tests/ghci/scripts/T6027ghci.stdout @@ -1 +1 @@ -data (?) -- Defined at <interactive>:3:1 +data (?) -- Defined at <interactive>:2:1 diff --git a/testsuite/tests/ghci/scripts/T7730.stdout b/testsuite/tests/ghci/scripts/T7730.stdout index e3a08c19f4..d91d058e53 100644 --- a/testsuite/tests/ghci/scripts/T7730.stdout +++ b/testsuite/tests/ghci/scripts/T7730.stdout @@ -1,8 +1,8 @@ type role A phantom phantom data A (x :: k) (y :: k1) - -- Defined at <interactive>:3:1 + -- Defined at <interactive>:2:1 A :: k -> k1 -> * type role T phantom data T (a :: k) where MkT :: forall (k :: BOX) (a :: k) a1. a1 -> T a - -- Defined at <interactive>:7:1 + -- Defined at <interactive>:6:1 diff --git a/testsuite/tests/ghci/scripts/T7872.stdout b/testsuite/tests/ghci/scripts/T7872.stdout index 81d960947c..4c577ce1cd 100644 --- a/testsuite/tests/ghci/scripts/T7872.stdout +++ b/testsuite/tests/ghci/scripts/T7872.stdout @@ -1,2 +1,2 @@ -type T = forall a. a -> a -- Defined at <interactive>:3:1 -data D = MkT (forall b. b -> b) -- Defined at <interactive>:4:1 +type T = forall a. a -> a -- Defined at <interactive>:2:1 +data D = MkT (forall b. b -> b) -- Defined at <interactive>:3:1 diff --git a/testsuite/tests/ghci/scripts/T7873.stdout b/testsuite/tests/ghci/scripts/T7873.stdout index 215757bb69..79a75ec7ea 100644 --- a/testsuite/tests/ghci/scripts/T7873.stdout +++ b/testsuite/tests/ghci/scripts/T7873.stdout @@ -1,7 +1,7 @@ data D1 where MkD1 :: (forall (k1 :: BOX) (p :: k1 -> *) (a :: k1). p a -> Int) -> D1 - -- Defined at <interactive>:3:1 + -- Defined at <interactive>:2:1 data D2 where MkD2 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D2 - -- Defined at <interactive>:4:1 + -- Defined at <interactive>:3:1 diff --git a/testsuite/tests/ghci/scripts/T8485.stderr b/testsuite/tests/ghci/scripts/T8485.stderr index bbef720fe2..d1c005b9f6 100644 --- a/testsuite/tests/ghci/scripts/T8485.stderr +++ b/testsuite/tests/ghci/scripts/T8485.stderr @@ -1,4 +1,4 @@ -<interactive>:3:11: error: +<interactive>:2:11: error: The role annotation for ‘X’ lacks an accompanying binding (The role annotation must be given where ‘X’ is declared) diff --git a/testsuite/tests/ghci/scripts/T8579.stdout b/testsuite/tests/ghci/scripts/T8579.stdout index 5220e7e37c..2db09d7fd4 100644 --- a/testsuite/tests/ghci/scripts/T8579.stdout +++ b/testsuite/tests/ghci/scripts/T8579.stdout @@ -1,2 +1,2 @@ -data A = Y -- Defined at <interactive>:3:1 -data A = Y -- Defined at <interactive>:3:1 +data A = Y -- Defined at <interactive>:2:1 +data A = Y -- Defined at <interactive>:2:1 diff --git a/testsuite/tests/ghci/scripts/T8649.stderr b/testsuite/tests/ghci/scripts/T8649.stderr index 257b112112..ae766e5aec 100644 --- a/testsuite/tests/ghci/scripts/T8649.stderr +++ b/testsuite/tests/ghci/scripts/T8649.stderr @@ -1,8 +1,8 @@ -<interactive>:5:4: error: +<interactive>:4:4: error: Couldn't match expected type ‘Ghci1.X’ with actual type ‘X’ - NB: ‘X’ is defined at <interactive>:4:1-25 - ‘Ghci1.X’ is defined at <interactive>:2:1-14 + NB: ‘X’ is defined at <interactive>:3:1-25 + ‘Ghci1.X’ is defined at <interactive>:1:1-14 In the first argument of ‘f’, namely ‘(Y 3)’ In the expression: f (Y 3) diff --git a/testsuite/tests/ghci/scripts/T8959.stderr b/testsuite/tests/ghci/scripts/T8959.stderr index b3995c3365..3f5707bd3a 100644 --- a/testsuite/tests/ghci/scripts/T8959.stderr +++ b/testsuite/tests/ghci/scripts/T8959.stderr @@ -3,7 +3,7 @@ Arrow command found where an expression was expected: () >- () -< () >>- () -<< () -<interactive>:7:15: +<interactive>:6:15: Couldn't match expected type ‘()’ with actual type ‘Bool’ In the pattern: True In a stmt of a pattern guard for @@ -15,7 +15,7 @@ Arrow command found where an expression was expected: () ↣ () ↢ () ⤜ () ⤛ () -<interactive>:14:15: +<interactive>:13:15: Couldn't match expected type ‘()’ with actual type ‘Bool’ In the pattern: True In a stmt of a pattern guard for @@ -27,7 +27,7 @@ Arrow command found where an expression was expected: () >- () -< () >>- () -<< () -<interactive>:21:15: +<interactive>:20:15: Couldn't match expected type ‘()’ with actual type ‘Bool’ In the pattern: True In a stmt of a pattern guard for diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout index 401c8741c5..d9520c0960 100644 --- a/testsuite/tests/ghci/scripts/T9140.stdout +++ b/testsuite/tests/ghci/scripts/T9140.stdout @@ -1,10 +1,10 @@ -<interactive>:3:5: +<interactive>:2:5: You can't mix polymorphic and unlifted bindings a = (# 1 #) Probable fix: use a bang pattern -<interactive>:4:5: +<interactive>:3:5: You can't mix polymorphic and unlifted bindings a = (# 1, 3 #) Probable fix: use a bang pattern diff --git a/testsuite/tests/ghci/scripts/T9293.stderr b/testsuite/tests/ghci/scripts/T9293.stderr index a663562a60..8c7ac45202 100644 --- a/testsuite/tests/ghci/scripts/T9293.stderr +++ b/testsuite/tests/ghci/scripts/T9293.stderr @@ -1,5 +1,5 @@ -<interactive>:5:1: error:
+<interactive>:4:1: error:
Illegal generalised algebraic data declaration for ‘T’
(Use GADTs to allow GADTs)
In the data declaration for ‘T’
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 1efa0099f1..bbd69ee014 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -209,6 +209,7 @@ test('T9878b', extra_run_opts('-fobject-code'), extra_clean(['T9878b.hi','T9878b.o'])], ghci_script, ['T9878b.script']) +test('T10018', normal, ghci_script, ['T10018.script']) test('T10122', normal, ghci_script, ['T10122.script']) test('T10321', normal, ghci_script, ['T10321.script']) diff --git a/testsuite/tests/ghci/scripts/ghci012.stdout b/testsuite/tests/ghci/scripts/ghci012.stdout index d19785b3ee..0fc695c4d1 100644 --- a/testsuite/tests/ghci/scripts/ghci012.stdout +++ b/testsuite/tests/ghci/scripts/ghci012.stdout @@ -1 +1 @@ -($$$) :: [a -> c] -> [a] -> [c] -- Defined at <interactive>:2:8 +($$$) :: [a -> c] -> [a] -> [c] -- Defined at <interactive>:1:8 diff --git a/testsuite/tests/ghci/scripts/ghci040.stdout b/testsuite/tests/ghci/scripts/ghci040.stdout index b440ef499d..d9ebd9c59e 100644 --- a/testsuite/tests/ghci/scripts/ghci040.stdout +++ b/testsuite/tests/ghci/scripts/ghci040.stdout @@ -1 +1 @@ -data Ghci1.T = A | ... -- Defined at <interactive>:3:10 +data Ghci1.T = A | ... -- Defined at <interactive>:2:10 diff --git a/testsuite/tests/ghci/scripts/ghci041.stdout b/testsuite/tests/ghci/scripts/ghci041.stdout index daf48fc25d..14b8726c76 100644 --- a/testsuite/tests/ghci/scripts/ghci041.stdout +++ b/testsuite/tests/ghci/scripts/ghci041.stdout @@ -1 +1 @@ -data R = A | ... -- Defined at <interactive>:4:10 +data R = A | ... -- Defined at <interactive>:3:10 diff --git a/testsuite/tests/ghci/scripts/ghci042.stdout b/testsuite/tests/ghci/scripts/ghci042.stdout index 2a75ecb496..5cb84f632f 100644 --- a/testsuite/tests/ghci/scripts/ghci042.stdout +++ b/testsuite/tests/ghci/scripts/ghci042.stdout @@ -1,6 +1,6 @@ -data T = A {...} -- Defined at <interactive>:3:10 -data T = A {a :: Int} -- Defined at <interactive>:3:13 -a :: Integer -- Defined at <interactive>:6:5 +data T = A {...} -- Defined at <interactive>:2:10 +data T = A {a :: Int} -- Defined at <interactive>:2:13 +a :: Integer -- Defined at <interactive>:5:5 3 -data R = B {a :: Int} -- Defined at <interactive>:9:13 -data T = A {Ghci1.a :: Int} -- Defined at <interactive>:3:1 +data R = B {a :: Int} -- Defined at <interactive>:8:13 +data T = A {Ghci1.a :: Int} -- Defined at <interactive>:2:1 diff --git a/testsuite/tests/ghci/scripts/ghci044.stderr b/testsuite/tests/ghci/scripts/ghci044.stderr index b49978dd39..9ff8acc5c7 100644 --- a/testsuite/tests/ghci/scripts/ghci044.stderr +++ b/testsuite/tests/ghci/scripts/ghci044.stderr @@ -1,8 +1,8 @@ -<interactive>:10:1: error: +<interactive>:9:1: error: Overlapping instances for C [Int] arising from a use of ‘f’ Matching instances: - instance [safe] C [Int] -- Defined at <interactive>:7:10 - instance [safe] C a => C [a] -- Defined at <interactive>:9:10 + instance [safe] C [Int] -- Defined at <interactive>:6:10 + instance [safe] C a => C [a] -- Defined at <interactive>:8:10 In the expression: f [4 :: Int] In an equation for ‘it’: it = f [4 :: Int] diff --git a/testsuite/tests/ghci/scripts/ghci047.stderr b/testsuite/tests/ghci/scripts/ghci047.stderr index 9428dbc1a9..dc8dfc9ecb 100644 --- a/testsuite/tests/ghci/scripts/ghci047.stderr +++ b/testsuite/tests/ghci/scripts/ghci047.stderr @@ -1,5 +1,5 @@ -<interactive>:39:1: +<interactive>:38:1: Couldn't match type ‘HFalse’ with ‘HTrue’ Expected type: HTrue Actual type: Or HFalse HFalse @@ -7,7 +7,7 @@ In the expression: f $ Baz 'a' In an equation for ‘it’: it = f $ Baz 'a' -<interactive>:40:1: +<interactive>:39:1: Couldn't match type ‘HFalse’ with ‘HTrue’ Expected type: HTrue Actual type: Or HFalse HFalse diff --git a/testsuite/tests/ghci/scripts/ghci048.stderr b/testsuite/tests/ghci/scripts/ghci048.stderr index 1b96e5da07..27cc18f708 100644 --- a/testsuite/tests/ghci/scripts/ghci048.stderr +++ b/testsuite/tests/ghci/scripts/ghci048.stderr @@ -1,10 +1,10 @@ -<interactive>:4:16: +<interactive>:3:16: Multiple declarations of ‘A’ - Declared at: <interactive>:4:12 - <interactive>:4:16 + Declared at: <interactive>:3:12 + <interactive>:3:16 -<interactive>:6:16: +<interactive>:5:16: Multiple declarations of ‘A’ - Declared at: <interactive>:6:12 - <interactive>:6:16 + Declared at: <interactive>:5:12 + <interactive>:5:16 diff --git a/testsuite/tests/ghci/scripts/ghci050.stderr b/testsuite/tests/ghci/scripts/ghci050.stderr index d1df9b8379..4b454bd8bf 100644 --- a/testsuite/tests/ghci/scripts/ghci050.stderr +++ b/testsuite/tests/ghci/scripts/ghci050.stderr @@ -1,13 +1,13 @@ -<interactive>:6:49: error: +<interactive>:5:49: error: Couldn't match expected type ‘ListableElem (a, a)’ with actual type ‘a’ ‘a’ is a rigid type variable bound by - the instance declaration at <interactive>:6:10 + the instance declaration at <interactive>:5:10 Relevant bindings include - b :: a (bound at <interactive>:6:43) - a :: a (bound at <interactive>:6:41) + b :: a (bound at <interactive>:5:43) + a :: a (bound at <interactive>:5:41) asList :: (a, a) -> [ListableElem (a, a)] - (bound at <interactive>:6:33) + (bound at <interactive>:5:33) In the expression: a In the expression: [a, b] diff --git a/testsuite/tests/ghci/scripts/ghci051.stderr b/testsuite/tests/ghci/scripts/ghci051.stderr index 2a528e847a..7a33dd57b6 100644 --- a/testsuite/tests/ghci/scripts/ghci051.stderr +++ b/testsuite/tests/ghci/scripts/ghci051.stderr @@ -1,9 +1,9 @@ -<interactive>:7:9: error: +<interactive>:6:9: error: Couldn't match type ‘T’ with ‘Ghci1.T’ - NB: ‘Ghci1.T’ is defined at <interactive>:3:1-14 - ‘T’ is defined at <interactive>:6:1-16 + NB: ‘Ghci1.T’ is defined at <interactive>:2:1-14 + ‘T’ is defined at <interactive>:5:1-16 Expected type: T' Actual type: T In the expression: C :: T' diff --git a/testsuite/tests/ghci/scripts/ghci051.stdout b/testsuite/tests/ghci/scripts/ghci051.stdout index f69b0e2de3..a3542869a5 100644 --- a/testsuite/tests/ghci/scripts/ghci051.stdout +++ b/testsuite/tests/ghci/scripts/ghci051.stdout @@ -1,9 +1,9 @@ -data T = C | D -- Defined at <interactive>:9:1 -type T' = Ghci1.T -- Defined at <interactive>:4:1 -data Ghci1.T = A | ... -- Defined at <interactive>:3:10 -data Ghci4.T = B | ... -- Defined at <interactive>:6:12 -data T = C | ... -- Defined at <interactive>:9:14 -data T = ... | D -- Defined at <interactive>:9:18 -b :: T' -- Defined at <interactive>:5:5 -c :: Ghci4.T -- Defined at <interactive>:8:5 -d :: T -- Defined at <interactive>:10:5 +data T = C | D -- Defined at <interactive>:8:1 +type T' = Ghci1.T -- Defined at <interactive>:3:1 +data Ghci1.T = A | ... -- Defined at <interactive>:2:10 +data Ghci4.T = B | ... -- Defined at <interactive>:5:12 +data T = C | ... -- Defined at <interactive>:8:14 +data T = ... | D -- Defined at <interactive>:8:18 +b :: T' -- Defined at <interactive>:4:5 +c :: Ghci4.T -- Defined at <interactive>:7:5 +d :: T -- Defined at <interactive>:9:5 diff --git a/testsuite/tests/ghci/scripts/ghci052.stderr b/testsuite/tests/ghci/scripts/ghci052.stderr index ce221887d6..4464891168 100644 --- a/testsuite/tests/ghci/scripts/ghci052.stderr +++ b/testsuite/tests/ghci/scripts/ghci052.stderr @@ -1,32 +1,32 @@ -<interactive>:9:4: error: +<interactive>:8:4: error: Couldn't match expected type ‘Ghci1.Planet’ with actual type ‘Planet’ - NB: ‘Planet’ is defined at <interactive>:8:1-36 - ‘Ghci1.Planet’ is defined at <interactive>:5:1-37 + NB: ‘Planet’ is defined at <interactive>:7:1-36 + ‘Ghci1.Planet’ is defined at <interactive>:4:1-37 In the first argument of ‘pn’, namely ‘Mercury’ In the expression: pn Mercury -<interactive>:10:4: error: +<interactive>:9:4: error: Couldn't match expected type ‘Ghci1.Planet’ with actual type ‘Planet’ - NB: ‘Planet’ is defined at <interactive>:8:1-36 - ‘Ghci1.Planet’ is defined at <interactive>:5:1-37 + NB: ‘Planet’ is defined at <interactive>:7:1-36 + ‘Ghci1.Planet’ is defined at <interactive>:4:1-37 In the first argument of ‘pn’, namely ‘Venus’ In the expression: pn Venus -<interactive>:11:4: error: +<interactive>:10:4: error: Couldn't match expected type ‘Ghci1.Planet’ with actual type ‘Planet’ - NB: ‘Planet’ is defined at <interactive>:8:1-36 - ‘Ghci1.Planet’ is defined at <interactive>:5:1-37 + NB: ‘Planet’ is defined at <interactive>:7:1-36 + ‘Ghci1.Planet’ is defined at <interactive>:4:1-37 In the first argument of ‘pn’, namely ‘Mars’ In the expression: pn Mars -<interactive>:13:44: error: +<interactive>:12:44: error: Couldn't match expected type ‘Planet’ with actual type ‘Ghci1.Planet’ - NB: ‘Ghci1.Planet’ is defined at <interactive>:5:1-37 - ‘Planet’ is defined at <interactive>:8:1-36 + NB: ‘Ghci1.Planet’ is defined at <interactive>:4:1-37 + ‘Planet’ is defined at <interactive>:7:1-36 In the pattern: Earth In an equation for ‘pn’: pn Earth = "E" diff --git a/testsuite/tests/ghci/scripts/ghci053.stderr b/testsuite/tests/ghci/scripts/ghci053.stderr index fe6d6c9bef..bb038faf23 100644 --- a/testsuite/tests/ghci/scripts/ghci053.stderr +++ b/testsuite/tests/ghci/scripts/ghci053.stderr @@ -1,16 +1,16 @@ -<interactive>:10:12: error: +<interactive>:9:12: error: Couldn't match expected type ‘Ghci1.Planet’ with actual type ‘Planet’ - NB: ‘Planet’ is defined at <interactive>:8:1-41 - ‘Ghci1.Planet’ is defined at <interactive>:5:1-49 + NB: ‘Planet’ is defined at <interactive>:7:1-41 + ‘Ghci1.Planet’ is defined at <interactive>:4:1-49 In the second argument of ‘(==)’, namely ‘Mercury’ In the expression: mercury == Mercury -<interactive>:12:10: error: +<interactive>:11:10: error: Couldn't match expected type ‘Planet’ with actual type ‘Ghci1.Planet’ - NB: ‘Ghci1.Planet’ is defined at <interactive>:5:1-49 - ‘Planet’ is defined at <interactive>:8:1-41 + NB: ‘Ghci1.Planet’ is defined at <interactive>:4:1-49 + ‘Planet’ is defined at <interactive>:7:1-41 In the second argument of ‘(==)’, namely ‘Earth’ In the expression: Venus == Earth diff --git a/testsuite/tests/ghci/scripts/ghci057.stderr b/testsuite/tests/ghci/scripts/ghci057.stderr index a663562a60..8c7ac45202 100644 --- a/testsuite/tests/ghci/scripts/ghci057.stderr +++ b/testsuite/tests/ghci/scripts/ghci057.stderr @@ -1,5 +1,5 @@ -<interactive>:5:1: error:
+<interactive>:4:1: error:
Illegal generalised algebraic data declaration for ‘T’
(Use GADTs to allow GADTs)
In the data declaration for ‘T’
diff --git a/testsuite/tests/ghci/should_run/T9914.stdout b/testsuite/tests/ghci/should_run/T9914.stdout index 3dd5aff3f3..d9407d3877 100644 --- a/testsuite/tests/ghci/should_run/T9914.stdout +++ b/testsuite/tests/ghci/should_run/T9914.stdout @@ -1,5 +1,5 @@ 1 2 2 -data T1 = MkT1 -- Defined at <interactive>:7:1 -data T2 = MkT2 -- Defined at <interactive>:9:2 +data T1 = MkT1 -- Defined at <interactive>:6:1 +data T2 = MkT2 -- Defined at <interactive>:8:2 diff --git a/testsuite/tests/ghci/should_run/T9915.stderr b/testsuite/tests/ghci/should_run/T9915.stderr index 333f17ac81..95f5758517 100644 --- a/testsuite/tests/ghci/should_run/T9915.stderr +++ b/testsuite/tests/ghci/should_run/T9915.stderr @@ -1,5 +1,5 @@ -<interactive>:3:9: error: +<interactive>:2:9: error: parse error on input ‘=’ Perhaps you need a 'let' in a 'do' block? e.g. 'let x = 5' instead of 'x = 5' diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T10398.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T10398.hs new file mode 100644 index 0000000000..bbd498cfad --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T10398.hs @@ -0,0 +1,25 @@ +module Foo +( + -- The reference to chunk2 should show up in the -ddump-parsed output. + -- $chunk1 + -- $chunk2 + foo, + -- $chunk3 + bar +) +where + +{- $chunk1 +This is chunk 1. +-} + +{- $chunk2 +This is chunk 2. +-} + +{- $chunk3 +This is chunk 3. +-} + +foo = 3 +bar = 7 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T10398.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T10398.stderr new file mode 100644 index 0000000000..4a51fcd55d --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T10398.stderr @@ -0,0 +1,13 @@ + +==================== Parser ==================== +module Foo ( + <IEDocNamed: chunk1>, <IEDocNamed: chunk2>, foo, + <IEDocNamed: chunk3>, bar + ) where +<document comment> +<document comment> +<document comment> +foo = 3 +bar = 7 + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/all.T b/testsuite/tests/haddock/should_compile_flag_haddock/all.T index 61b6c6c1e0..a0d1d7c07d 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/all.T +++ b/testsuite/tests/haddock/should_compile_flag_haddock/all.T @@ -31,3 +31,5 @@ test('haddockA030', normal, compile, ['-haddock -ddump-parsed']) test('haddockA031', normal, compile, ['-haddock -ddump-parsed -XExistentialQuantification']) test('haddockA032', normal, compile, ['-haddock -ddump-parsed']) test('haddockA033', normal, compile, ['-haddock -ddump-parsed']) +test('haddockA034', normal, compile, ['-haddock -ddump-parsed']) +test('T10398', normal, compile, ['-haddock -ddump-parsed']) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.hs new file mode 100644 index 0000000000..195d76c34a --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} + +module Hi where + +-- | This is a GADT. +data Hi where + -- | This is a GADT constructor. + Hi :: () -> Hi diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr new file mode 100644 index 0000000000..f743393349 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr @@ -0,0 +1,5 @@ + +==================== Parser ==================== +module Hi where +<document comment> +data Hi where This is a GADT constructor. Hi :: () -> Hi diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 520460da36..943908249d 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -2,6 +2,7 @@ ==================== Tidy Core ====================
Result size of Tidy Core = {terms: 22, types: 14, coercions: 0}
+-- RHS size: {terms: 8, types: 3, coercions: 0}
dl :: Double -> Double
[GblId,
Arity=1,
@@ -15,6 +16,7 @@ dl :: Double -> Double dl =
\ (x :: Double) -> case x of _ [Occ=Dead] { D# y -> D# (+## y y) }
+-- RHS size: {terms: 1, types: 0, coercions: 0}
dr :: Double -> Double
[GblId,
Arity=1,
@@ -27,6 +29,7 @@ dr :: Double -> Double case x of _ [Occ=Dead] { D# x1 -> D# (+## x1 x1) }}]
dr = dl
+-- RHS size: {terms: 8, types: 3, coercions: 0}
fl :: Float -> Float
[GblId,
Arity=1,
@@ -41,6 +44,7 @@ fl = \ (x :: Float) ->
case x of _ [Occ=Dead] { F# y -> F# (plusFloat# y y) }
+-- RHS size: {terms: 1, types: 0, coercions: 0}
fr :: Float -> Float
[GblId,
Arity=1,
diff --git a/testsuite/tests/package/package09e.stderr b/testsuite/tests/package/package09e.stderr index 9cd00a2930..70c6f22d89 100644 --- a/testsuite/tests/package/package09e.stderr +++ b/testsuite/tests/package/package09e.stderr @@ -1,5 +1,5 @@ package09e.hs:2:1: Ambiguous interface for ‘M’: - it is bound as Data.Set by a package flag it is bound as Data.Map by a package flag + it is bound as Data.Set by a package flag diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index 521b5a42a0..0030040aed 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -41,7 +41,7 @@ test('read025', normal, compile, ['']) test('read026', normal, compile, ['']) test('read027', normal, compile, ['']) test('read028', normal, compile, ['']) -test('read029', normal, compile, ['']) +test('read029', expect_broken_for(10181, ['optasm', 'optllvm']), compile, ['']) test('read030', normal, compile, ['']) test('read031', normal, compile, ['']) test('read032', normal, compile, ['']) diff --git a/testsuite/tests/partial-sigs/should_compile/Splices.hs b/testsuite/tests/partial-sigs/should_compile/Splices.hs new file mode 100644 index 0000000000..9202c18995 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/Splices.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedWildCards #-} +module Splices where + +import Language.Haskell.TH +import Language.Haskell.TH.Lib (wildCardT) + +metaType1 :: TypeQ +metaType1 = wildCardT + +metaType2 :: TypeQ +metaType2 = [t| _ |] + +metaType3 :: TypeQ +metaType3 = [t| _ -> _ -> _ |] + +metaDec1 :: Q [Dec] +metaDec1 = [d| foo :: _ => _ + foo x y = x == y |] + +metaDec2 :: Q [Dec] +metaDec2 = [d| bar :: _a -> _b -> (_a, _b) + bar x y = (not x, y) |] + +-- An expression with a partial type annotation +metaExp1 :: ExpQ +metaExp1 = [| Just True :: Maybe _ |] + +metaExp2 :: ExpQ +metaExp2 = [| id :: _a -> _a |] diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.hs b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.hs new file mode 100644 index 0000000000..21e599dcf6 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PartialTypeSignatures #-} +module SplicesUsed where + +import Splices + +maybeBool :: $(metaType1) +maybeBool = $(metaExp2) $(metaExp1) + +charA :: a -> $(metaType2) +charA x = ('x', x) + +filter' :: $(metaType3) +filter' = filter + +$(metaDec1) + +$(metaDec2) diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr new file mode 100644 index 0000000000..312cf25217 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -0,0 +1,73 @@ +[1 of 2] Compiling Splices ( Splices.hs, Splices.o ) +[2 of 2] Compiling SplicesUsed ( SplicesUsed.hs, SplicesUsed.o ) + +SplicesUsed.hs:7:16: warning: + Found type wildcard ‘_’ standing for ‘Maybe Bool’ + In the type signature for ‘maybeBool’: _ + +SplicesUsed.hs:8:15: warning: + Found type wildcard ‘_a’ standing for ‘Maybe Bool’ + Relevant bindings include + maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) + In an expression type signature: _a -> _a + In the expression: id :: _a -> _a + In the expression: (id :: _a -> _a) (Just True :: Maybe _) + +SplicesUsed.hs:8:27: warning: + Found type wildcard ‘_’ standing for ‘Bool’ + Relevant bindings include + maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) + In an expression type signature: Maybe _ + In the first argument of ‘id :: _a -> _a’, namely + ‘(Just True :: Maybe _)’ + In the expression: (id :: _a -> _a) (Just True :: Maybe _) + +SplicesUsed.hs:10:17: warning: + Found type wildcard ‘_’ standing for ‘(Char, a)’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of charA :: a -> (Char, a) + at SplicesUsed.hs:10:10 + In the type signature for ‘charA’: a -> _ + +SplicesUsed.hs:13:14: warning: + Found type wildcard ‘_’ standing for ‘a -> Bool’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of filter' :: (a -> Bool) -> [a] -> [a] + at SplicesUsed.hs:14:1 + In the type signature for ‘filter'’: _ -> _ -> _ + +SplicesUsed.hs:13:14: warning: + Found type wildcard ‘_’ standing for ‘[a]’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of filter' :: (a -> Bool) -> [a] -> [a] + at SplicesUsed.hs:14:1 + In the type signature for ‘filter'’: _ -> _ -> _ + +SplicesUsed.hs:13:14: warning: + Found type wildcard ‘_’ standing for ‘[a]’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of filter' :: (a -> Bool) -> [a] -> [a] + at SplicesUsed.hs:14:1 + In the type signature for ‘filter'’: _ -> _ -> _ + +SplicesUsed.hs:16:3: warning: + Found hole ‘_’ with inferred constraints: Eq a + In the type signature for ‘foo’: _ => _ + +SplicesUsed.hs:16:3: warning: + Found type wildcard ‘_’ standing for ‘a -> a -> Bool’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: Eq a => a -> a -> Bool + at SplicesUsed.hs:16:3 + In the type signature for ‘foo’: _ => _ + +SplicesUsed.hs:18:3: warning: + Found type wildcard ‘_a’ standing for ‘Bool’ + In the type signature for ‘bar’: _a -> _b -> (_a, _b) + +SplicesUsed.hs:18:3: warning: + Found type wildcard ‘_b’ standing for ‘w_b’ + Where: ‘w_b’ is a rigid type variable bound by + the inferred type of bar :: Bool -> w_b -> (Bool, w_b) + at SplicesUsed.hs:18:3 + In the type signature for ‘bar’: _a -> _b -> (_a, _b) diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs b/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs new file mode 100644 index 0000000000..ef09c4d093 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} +module TypedSplice where + +import Language.Haskell.TH + +metaExp :: Q (TExp (Bool -> Bool)) +metaExp = [|| not :: _ -> _b ||] diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr new file mode 100644 index 0000000000..3cfa776ef1 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr @@ -0,0 +1,16 @@ + +TypedSplice.hs:9:22: warning: + Found type wildcard ‘_’ standing for ‘Bool’ + Relevant bindings include + metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1) + In an expression type signature: _ -> _b + In the Template Haskell quotation [|| not :: _ -> _b ||] + In the expression: [|| not :: _ -> _b ||] + +TypedSplice.hs:9:27: warning: + Found type wildcard ‘_b’ standing for ‘Bool’ + Relevant bindings include + metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1) + In an expression type signature: _ -> _b + In the Template Haskell quotation [|| not :: _ -> _b ||] + In the expression: [|| not :: _ -> _b ||] diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index c86e14ed38..5597183712 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -46,6 +46,10 @@ test('SomethingShowable', normal, compile, ['-ddump-types -fno-warn-partial-type test('Uncurry', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('UncurryNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('WarningWildcardInstantiations', normal, compile, ['-ddump-types']) +test('SplicesUsed', [req_interp, only_compiler_types(['ghc']), when(compiler_profiled(), skip), + extra_clean(['Splices.o', 'Splices.hi'])], + multimod_compile, ['SplicesUsed', '']) +test('TypedSplice', [req_interp, normal], compile, ['']) test('T10403', normal, compile, ['']) test('T10438', normal, compile, ['']) test('T10519', normal, compile, ['']) diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.hs new file mode 100644 index 0000000000..8a7ce369e8 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.hs @@ -0,0 +1,3 @@ +module ExtraConstraintsWildcardInExpressionSignature where + +foo x y = ((==) :: _ => _) x y diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr new file mode 100644 index 0000000000..5432eafc4e --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr @@ -0,0 +1,6 @@ + +ExtraConstraintsWildcardInExpressionSignature.hs:3:20: error: + Invalid partial type: _ => _ + An extra-constraints wild card is only allowed + in the top-level context + In an expression type signature diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.hs new file mode 100644 index 0000000000..9fcbf51cbe --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSignature where + +foo (x :: _ => _) y = x == y diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr new file mode 100644 index 0000000000..71b3132dc5 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr @@ -0,0 +1,6 @@ + +ExtraConstraintsWildcardInPatternSignature.hs:4:11: error: + Invalid partial type: _ => _ + An extra-constraints wild card is only allowed + in the top-level context + In a pattern type-signature diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs new file mode 100644 index 0000000000..1015fd53d1 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSplice where + +foo $( [p| (x :: _) |] ) = x diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr new file mode 100644 index 0000000000..784f437966 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr @@ -0,0 +1,4 @@ + +ExtraConstraintsWildcardInPatternSplice.hs:5:8: error: + Type signatures in patterns not (yet) handled by Template Haskell + x :: _ diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice.hs new file mode 100644 index 0000000000..c8c54f7819 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSplice where + +import Language.Haskell.TH + +metaType :: TypeQ +metaType = [t| _ => _ |] diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs new file mode 100644 index 0000000000..4f6822c7c4 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSplice2 where + +import Language.Haskell.TH.Lib (wildCardT) + +show' :: $(wildCardT) => a -> String +show' x = show x diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr new file mode 100644 index 0000000000..30efa4d83f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr @@ -0,0 +1,4 @@ + +ExtraConstraintsWildcardInTypeSplice2.hs:6:12: error: + Unexpected wild card: ‘_’ + In the type signature for ‘show'’: show' :: (_) => a -> String diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.hs new file mode 100644 index 0000000000..632f66798f --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSpliceUsed where + +import ExtraConstraintsWildcardInTypeSplice + +-- An extra-constraints wild card is not supported in type splices +eq :: $(metaType) +eq x y = x == y diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr new file mode 100644 index 0000000000..c13fe94d89 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr @@ -0,0 +1,8 @@ +[1 of 2] Compiling ExtraConstraintsWildcardInTypeSplice ( ExtraConstraintsWildcardInTypeSplice.hs, ExtraConstraintsWildcardInTypeSplice.o ) +[2 of 2] Compiling ExtraConstraintsWildcardInTypeSpliceUsed ( ExtraConstraintsWildcardInTypeSpliceUsed.hs, ExtraConstraintsWildcardInTypeSpliceUsed.o ) + +ExtraConstraintsWildcardInTypeSpliceUsed.hs:7:9: error: + Invalid partial type: _ => _ + An extra-constraints wild card is not allowed in a type splice + In the spliced type _ => _ + In the untyped splice: $metaType diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.hs new file mode 100644 index 0000000000..c0c5fcab7c --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedWildCards #-} +module NamedWildcardInTypeSplice where + +import Language.Haskell.TH + +metaType :: TypeQ +metaType = [t| _a -> _a |] diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr new file mode 100644 index 0000000000..9071531a13 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr @@ -0,0 +1,5 @@ + +NamedWildcardInTypeSplice.hs:8:16: error: + Unexpected wild card: ‘_a’ + In a Template-Haskell quoted type + In the Template Haskell quotation [t| _a -> _a |] diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeBrackets.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeBrackets.hs deleted file mode 100644 index f11ac5a9f1..0000000000 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeBrackets.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module WildcardInTypeBrackets where - -foo = [t| _ |] diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeBrackets.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeBrackets.stderr deleted file mode 100644 index f72fa7a3aa..0000000000 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeBrackets.stderr +++ /dev/null @@ -1,2 +0,0 @@ - -WildcardInTypeBrackets.hs:4:11: Unexpected wild card: ‘_’ diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T index 44a35b1cee..9417a3ed8f 100644 --- a/testsuite/tests/partial-sigs/should_fail/all.T +++ b/testsuite/tests/partial-sigs/should_fail/all.T @@ -1,6 +1,16 @@ test('AnnotatedConstraint', normal, compile_fail, ['']) test('AnnotatedConstraintNotForgotten', normal, compile_fail, ['']) test('Defaulting1MROff', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardInExpressionSignature', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardInPatternSignature', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardInPatternSplice', normal, compile_fail, ['']) +test('ExtraConstraintsWildcardInTypeSpliceUsed', + [req_interp, when(compiler_profiled(), skip), + extra_clean(['ExtraConstraintsWildcardInTypeSplice.o', 'ExtraConstraintsWildcardInTypeSplice.hi'])], + multimod_compile_fail, ['ExtraConstraintsWildcardInTypeSpliceUsed', '']) +test('ExtraConstraintsWildcardInTypeSplice2', + [req_interp, when(compiler_profiled(), skip)], + compile_fail, ['']) test('ExtraConstraintsWildcardNotEnabled', normal, compile_fail, ['']) test('ExtraConstraintsWildcardNotLast', normal, compile_fail, ['']) test('ExtraConstraintsWildcardNotPresent', normal, compile_fail, ['']) @@ -8,6 +18,7 @@ test('ExtraConstraintsWildcardTwice', normal, compile_fail, ['']) test('Forall1Bad', normal, compile_fail, ['']) test('InstantiatedNamedWildcardsInConstraints', normal, compile_fail, ['']) test('NamedExtraConstraintsWildcard', normal, compile_fail, ['']) +test('NamedWildcardInTypeSplice', normal, compile_fail, ['']) test('NamedWildcardsEnabled', normal, compile_fail, ['']) test('NamedWildcardsNotEnabled', normal, compile_fail, ['']) test('NamedWildcardsNotInMonotype', normal, compile_fail, ['']) @@ -42,7 +53,6 @@ test('WildcardInPatSynSig', normal, compile_fail, ['']) test('WildcardInNewtype', normal, compile_fail, ['']) test('WildcardInStandaloneDeriving', normal, compile_fail, ['']) test('WildcardInstantiations', normal, compile_fail, ['']) -test('WildcardInTypeBrackets', req_interp, compile_fail, ['']) test('WildcardInTypeFamilyInstanceLHS', normal, compile_fail, ['']) test('WildcardInTypeFamilyInstanceRHS', normal, compile_fail, ['']) test('WildcardInTypeSynonymLHS', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_run/ghci.stderr b/testsuite/tests/patsyn/should_run/ghci.stderr index 9593b15633..9740d06859 100644 --- a/testsuite/tests/patsyn/should_run/ghci.stderr +++ b/testsuite/tests/patsyn/should_run/ghci.stderr @@ -1,2 +1,2 @@ -*** Exception: <interactive>:6:5-35: Non-exhaustive patterns in function foo +*** Exception: <interactive>:5:5-35: Non-exhaustive patterns in function foo diff --git a/testsuite/tests/patsyn/should_run/ghci.stdout b/testsuite/tests/patsyn/should_run/ghci.stdout index e434de3dd6..3dcecbc7a6 100644 --- a/testsuite/tests/patsyn/should_run/ghci.stdout +++ b/testsuite/tests/patsyn/should_run/ghci.stdout @@ -1,3 +1,3 @@ -pattern Single :: t -> [t] -- Defined at <interactive>:4:1 +pattern Single :: t -> [t] -- Defined at <interactive>:3:1 foo :: [Bool] -> [Bool] [False] diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 94f7cbd8ac..1e5a16c9c7 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -5,7 +5,7 @@ test('haddock.base', [unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 9014511528, 5) + [(wordsize(64), 9418857192, 5) # 2012-08-14: 5920822352 (amd64/Linux) # 2012-09-20: 5829972376 (amd64/Linux) # 2012-10-08: 5902601224 (amd64/Linux) @@ -23,6 +23,7 @@ test('haddock.base', # 2014-10-07: 8322584616 (x86_64/Linux) # 2014-12-14: 9502647104 (x86_64/Linux) - Update to Haddock 2.16 # 2014-01-08: 9014511528 (x86_64/Linux) - Eliminate so-called "silent superclass parameters" (and others) + # 2015-07-22: 9418857192 (x86_64/Linux) - Just slowly creeping up. ,(platform('i386-unknown-mingw32'), 4434804940, 5) # 2013-02-10: 3358693084 (x86/Windows) diff --git a/testsuite/tests/polykinds/T10670.hs b/testsuite/tests/polykinds/T10670.hs new file mode 100644 index 0000000000..5b9cc72e21 --- /dev/null +++ b/testsuite/tests/polykinds/T10670.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTs, PolyKinds #-} + +module T10670 where + +import Unsafe.Coerce + +data TypeRepT (a::k) where + TRCon :: TypeRepT a + +data G2 c a where + G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) + +getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) +{-# NOINLINE getT2 #-} +getT2 c t = Nothing + +tyRepTArr :: TypeRepT (->) +{-# NOINLINE tyRepTArr #-} +tyRepTArr = TRCon + +s :: forall a x. TypeRepT (a :: *) -> Maybe x +s tf = case getT2 tyRepTArr tf :: Maybe (G2 (->) a) of + Just (G2 _ _) -> Nothing + _ -> Nothing diff --git a/testsuite/tests/polykinds/T10670a.hs b/testsuite/tests/polykinds/T10670a.hs new file mode 100644 index 0000000000..d398cb72a8 --- /dev/null +++ b/testsuite/tests/polykinds/T10670a.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GADTs , PolyKinds #-} + +module Bug2 where + +import Unsafe.Coerce + +data TyConT (a::k) = TyConT String + +eqTyConT :: TyConT a -> TyConT b -> Bool +eqTyConT (TyConT a) (TyConT b) = a == b + + + +tyConTArr :: TyConT (->) +tyConTArr = TyConT "(->)" + + +data TypeRepT (a::k) where + TRCon :: TyConT a -> TypeRepT a + TRApp :: TypeRepT a -> TypeRepT b -> TypeRepT (a b) + + +data GetAppT a where + GA :: TypeRepT a -> TypeRepT b -> GetAppT (a b) + +getAppT :: TypeRepT a -> Maybe (GetAppT a) +getAppT (TRApp a b) = Just $ GA a b +getAppT _ = Nothing + + + +eqTT :: TypeRepT (a::k1) -> TypeRepT (b::k2) -> Bool +eqTT (TRCon a) (TRCon b) = eqTyConT a b +eqTT (TRApp c a) (TRApp d b) = eqTT c d && eqTT a b +eqTT _ _ = False + + +data G2 c a where + G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) + + +getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) +getT2 c t = do GA t' b <- getAppT t + GA c' a <- getAppT t' + if eqTT c c' + then Just (unsafeCoerce $ G2 a b :: G2 c a) + else Nothing + +tyRepTArr :: TypeRepT (->) +tyRepTArr = TRCon tyConTArr + +s tf = case getT2 tyRepTArr tf + of Just (G2 _ _) -> Nothing + _ -> Nothing diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T index c05e47e4a9..3c8096cbcb 100644 --- a/testsuite/tests/polykinds/all.T +++ b/testsuite/tests/polykinds/all.T @@ -117,3 +117,5 @@ test('T10451', normal, compile_fail, ['']) test('T10516', normal, compile_fail, ['']) test('T10503', normal, compile_fail, ['']) test('T10570', normal, compile_fail, ['']) +test('T10670', normal, compile, ['']) +test('T10670a', normal, compile, ['']) diff --git a/testsuite/tests/primops/should_run/T9430.hs b/testsuite/tests/primops/should_run/T9430.hs index 571b6db37d..aec2d264a1 100644 --- a/testsuite/tests/primops/should_run/T9430.hs +++ b/testsuite/tests/primops/should_run/T9430.hs @@ -73,3 +73,21 @@ main = do checkW (1, minBound + 1) plusWord2# maxBound 2 check "plusWord2# 2 maxBound" $ checkW (1, minBound + 1) plusWord2# 2 maxBound + + check "timesWord2# maxBound 0" $ checkW (0, 0) timesWord2# maxBound 0 + check "timesWord2# 0 maxBound" $ checkW (0, 0) timesWord2# 0 maxBound + check "timesWord2# maxBound 1" $ checkW (0, maxBound) timesWord2# maxBound 1 + check "timesWord2# 1 maxBound" $ checkW (0, maxBound) timesWord2# 1 maxBound + -- Overflows + check "timesWord2# " $ checkW (1, 0) timesWord2# (2 ^ 63) 2 + check "timesWord2# " $ checkW (2, 0) timesWord2# (2 ^ 63) (2 ^ 2) + check "timesWord2# " $ checkW (4, 0) timesWord2# (2 ^ 63) (2 ^ 3) + check "timesWord2# " $ checkW (8, 0) timesWord2# (2 ^ 63) (2 ^ 4) + check "timesWord2# maxBound 2" $ + checkW (1, maxBound - 1) timesWord2# maxBound 2 + check "timesWord2# 2 maxBound" $ + checkW (1, maxBound - 1) timesWord2# 2 maxBound + check "timesWord2# maxBound 3" $ + checkW (2, maxBound - 2) timesWord2# maxBound 3 + check "timesWord2# 3 maxBound" $ + checkW (2, maxBound - 2) timesWord2# 3 maxBound diff --git a/testsuite/tests/quasiquotation/qq007/test.T b/testsuite/tests/quasiquotation/qq007/test.T index 0b4448cdc0..d9a2df31d3 100644 --- a/testsuite/tests/quasiquotation/qq007/test.T +++ b/testsuite/tests/quasiquotation/qq007/test.T @@ -2,6 +2,7 @@ test('qq007', [when(fast(), skip), extra_clean(['QQ.hi', 'QQ.o', 'Test.hi', 'Test.o']), pre_cmd('$MAKE -s --no-print-directory TH_QQ'), + expect_broken(10047), ], multimod_compile, ['Test', '-v0']) diff --git a/testsuite/tests/quasiquotation/qq008/test.T b/testsuite/tests/quasiquotation/qq008/test.T index 8cac1a9f0a..5bdd2a9822 100644 --- a/testsuite/tests/quasiquotation/qq008/test.T +++ b/testsuite/tests/quasiquotation/qq008/test.T @@ -2,6 +2,7 @@ test('qq008', [when(fast(), skip), extra_clean(['QQ.hi', 'QQ.o', 'Test.hi', 'Test.o']), pre_cmd('$MAKE -s --no-print-directory TH_QQ'), + expect_broken(10047), ], multimod_compile, ['Test', '-v0']) diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 7f0d410b58..8a597827fe 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -53,7 +53,7 @@ test('rn037', normal, compile, ['']) test('rn039', normal, compile, ['']) test('rn040', normal, compile, ['-fwarn-unused-binds -fwarn-unused-matches']) -test('rn041', normal, compile, ['']) +test('rn041', expect_broken_for(10181, ['optasm', 'optllvm']), compile, ['']) test('rn042', extra_clean(['Rn042_A.hi', 'Rn042_A.o']), multimod_compile, diff --git a/testsuite/tests/rename/should_fail/T10668.hs b/testsuite/tests/rename/should_fail/T10668.hs new file mode 100644 index 0000000000..111637b19b --- /dev/null +++ b/testsuite/tests/rename/should_fail/T10668.hs @@ -0,0 +1,3 @@ +module T10668 where + +import Data.Type.Equality(Refl) diff --git a/testsuite/tests/rename/should_fail/T10668.stderr b/testsuite/tests/rename/should_fail/T10668.stderr new file mode 100644 index 0000000000..8c96fad1a8 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T10668.stderr @@ -0,0 +1,8 @@ + +T10668.hs:3:27: error: + In module ‘Data.Type.Equality’: + ‘Refl’ is a data constructor of ‘(:~:)’ + To import it use + ‘import’ Data.Type.Equality( (:~:)( Refl ) ) + or + ‘import’ Data.Type.Equality( (:~:)(..) ) diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index bfd81c51f9..80471a6960 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -134,3 +134,4 @@ test('T9032', run_command, ['$MAKE -s --no-print-directory T9032']) test('T10618', normal, compile_fail, ['']) +test('T10668', normal, compile_fail, ['']) diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index dc03073428..5ecdd16e10 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -2,10 +2,12 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 5, types: 9, coercions: 5} +-- RHS size: {terms: 2, types: 2, coercions: 0} a :: Wrap Age -> Wrap Age [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] a = \ (ds :: Wrap Age) -> ds +-- RHS size: {terms: 1, types: 0, coercions: 5} convert :: Wrap Age -> Int [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] convert = diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile index 644d74110e..52de19c876 100644 --- a/testsuite/tests/rts/Makefile +++ b/testsuite/tests/rts/Makefile @@ -7,19 +7,19 @@ outofmem-prep:: outofmem:: @$(MAKE) outofmem-prep - @ulimit -v 10000000 2>/dev/null; ./outofmem || echo "exit($$?)" + @ulimit -m 10000000 2>/dev/null; ./outofmem || echo "exit($$?)" outofmem2-prep:: '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -rtsopts --make -fforce-recomp outofmem2.hs -o outofmem2 outofmem2:: @$(MAKE) outofmem2-prep - @ulimit -v 1000000 2>/dev/null; ./outofmem2 +RTS -M5m -RTS || echo "exit($$?)" + @ulimit -m 1000000 2>/dev/null; ./outofmem2 +RTS -M5m -RTS || echo "exit($$?)" T2615-prep: $(RM) libfoo_T2615.so '$(TEST_HC)' $(TEST_HC_OPTS) -fPIC -c libfoo_T2615.c -o libfoo_T2615.o - '$(TEST_HC)' $(TEST_HC_OPTS) -shared -no-auto-link-packages libfoo_T2615.o -o libfoo_T2615.so + '$(TEST_HC)' $(filter-out -rtsopts, $(TEST_HC_OPTS)) -shared -no-auto-link-packages libfoo_T2615.o -o libfoo_T2615.so .PHONY: T4059 T4059: diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 0e892499e0..0e891e8f1b 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -2,6 +2,13 @@ test('testblockalloc', [c_src, only_ways(['normal','threaded1']), extra_run_opts('+RTS -I0')], compile_and_run, ['']) +test('testmblockalloc', + [c_src, only_ways(['normal','threaded1']), extra_run_opts('+RTS -I0')], + compile_and_run, ['']) +# -I0 is important: the idle GC will run the memory leak detector, +# which will crash because the mblocks we allocate are not in a state +# the leak detector is expecting. + # See bug #101, test requires +RTS -c (or equivalently +RTS -M<something>) # only GHCi triggers the bug, but we run the test all ways for completeness. @@ -217,6 +224,7 @@ test('ffishutdown', [ ignore_output, only_ways(['threaded1','threaded2']) ], com test('T7919', [extra_clean(['T7919A.o','T7919A.hi', 'T7919A.dyn_o','T7919A.dyn_hi']), + expect_broken_for(7919, ['optasm','dyn','optllvm']), when(fast(),skip) ], compile_and_run, [config.ghc_th_way_flags]) diff --git a/testsuite/tests/rts/outofmem.stderr-ws-64 b/testsuite/tests/rts/outofmem.stderr-ws-64 index 42a4696fcf..dca02c7ed8 100644 --- a/testsuite/tests/rts/outofmem.stderr-ws-64 +++ b/testsuite/tests/rts/outofmem.stderr-ws-64 @@ -1 +1 @@ -outofmem: out of memory (requested 2148532224 bytes) +outofmem: out of memory diff --git a/testsuite/tests/rts/outofmem.stdout b/testsuite/tests/rts/outofmem.stdout index 63a3a6988c..1acdde769d 100644 --- a/testsuite/tests/rts/outofmem.stdout +++ b/testsuite/tests/rts/outofmem.stdout @@ -1 +1 @@ -exit(1) +exit(251) diff --git a/testsuite/tests/rts/testmblockalloc.c b/testsuite/tests/rts/testmblockalloc.c new file mode 100644 index 0000000000..df03658387 --- /dev/null +++ b/testsuite/tests/rts/testmblockalloc.c @@ -0,0 +1,75 @@ +#include "Rts.h" + +#include <stdio.h> + +// 16 * 64 == max 1GB +const int MAXALLOC = 16; +const int ARRSIZE = 64; + +const int LOOPS = 1000; +const int SEED = 0xf00f00; + +extern lnat mblocks_allocated; + +int main (int argc, char *argv[]) +{ + int i, j, b; + + void *a[ARRSIZE]; + nat sizes[ARRSIZE]; + + srand(SEED); + + { + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &argv, conf); + } + + // repeatedly sweep though the array, allocating new random-sized + // objects and deallocating the old ones. + for (i=0; i < LOOPS; i++) + { + for (j=0; j < ARRSIZE; j++) + { + if (i > 0) + { + freeMBlocks(a[j], sizes[j]); + } + b = (rand() % MAXALLOC) + 1; + a[j] = getMBlocks(b); + sizes[j] = b; + } + } + + releaseFreeMemory(); + + for (j=0; j < ARRSIZE; j++) + { + freeMBlocks(a[j], sizes[j]); + } + + releaseFreeMemory(); + + // this time, sweep forwards allocating new blocks, and then + // backwards deallocating them. + for (i=0; i < LOOPS; i++) + { + for (j=0; j < ARRSIZE; j++) + { + b = (rand() % MAXALLOC) + 1; + a[j] = getMBlocks(b); + sizes[j] = b; + } + for (j=ARRSIZE-1; j >= 0; j--) + { + freeMBlocks(a[j], sizes[j]); + } + } + + releaseFreeMemory(); + + hs_exit(); // will do a memory leak test + + exit(0); +} diff --git a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout index 12223e534a..a3810ffb8b 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout +++ b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout @@ -29,17 +29,17 @@ trusted: safe require own pkg trusted: True M_SafePkg6 -package dependencies: array-0.5.1.0 bytestring-0.10.6.0* deepseq-1.4.1.1 base-4.8.2.0* ghc-prim-0.4.0.0 integer-gmp-1.0.0.0 +package dependencies: bytestring-0.10.6.0* deepseq-1.4.1.1 array-0.5.1.0 base-4.8.2.0* ghc-prim-0.4.0.0 integer-gmp-1.0.0.0 trusted: trustworthy require own pkg trusted: False M_SafePkg7 -package dependencies: array-0.5.1.0 bytestring-0.10.6.0* deepseq-1.4.1.1 base-4.8.2.0* ghc-prim-0.4.0.0 integer-gmp-1.0.0.0 +package dependencies: bytestring-0.10.6.0* deepseq-1.4.1.1 array-0.5.1.0 base-4.8.2.0* ghc-prim-0.4.0.0 integer-gmp-1.0.0.0 trusted: safe require own pkg trusted: False M_SafePkg8 -package dependencies: array-0.5.1.0 bytestring-0.10.6.0* deepseq-1.4.1.1 base-4.8.2.0 ghc-prim-0.4.0.0 integer-gmp-1.0.0.0 +package dependencies: bytestring-0.10.6.0* deepseq-1.4.1.1 array-0.5.1.0 base-4.8.2.0 ghc-prim-0.4.0.0 integer-gmp-1.0.0.0 trusted: trustworthy require own pkg trusted: False diff --git a/testsuite/tests/safeHaskell/ghci/p10.stderr b/testsuite/tests/safeHaskell/ghci/p10.stderr index e20f84f241..5104dd6a96 100644 --- a/testsuite/tests/safeHaskell/ghci/p10.stderr +++ b/testsuite/tests/safeHaskell/ghci/p10.stderr @@ -1,2 +1,2 @@ -<interactive>:10:1: error: Variable not in scope: b
+<interactive>:9:1: error: Variable not in scope: b
diff --git a/testsuite/tests/safeHaskell/ghci/p13.stderr b/testsuite/tests/safeHaskell/ghci/p13.stderr index f7e8b8524b..7ba149a36b 100644 --- a/testsuite/tests/safeHaskell/ghci/p13.stderr +++ b/testsuite/tests/safeHaskell/ghci/p13.stderr @@ -1,10 +1,10 @@ -<interactive>:11:1: error: +<interactive>:10:1: error: Unsafe overlapping instances for Pos [Int] arising from a use of ‘res’ The matching instance is: instance [overlapping] [safe] Pos [Int] - -- Defined at <interactive>:9:30 + -- Defined at <interactive>:8:30 It is compiled in a Safe module and as such can only overlap instances from the same module, however it overlaps the following instances from different modules: diff --git a/testsuite/tests/safeHaskell/ghci/p14.stderr b/testsuite/tests/safeHaskell/ghci/p14.stderr index 4d0b14e970..b015016622 100644 --- a/testsuite/tests/safeHaskell/ghci/p14.stderr +++ b/testsuite/tests/safeHaskell/ghci/p14.stderr @@ -1,2 +1,2 @@ -<interactive>:10:1: parse error on input ‘{-# RULES’ +<interactive>:9:1: parse error on input ‘{-# RULES’ diff --git a/testsuite/tests/safeHaskell/ghci/p16.stderr b/testsuite/tests/safeHaskell/ghci/p16.stderr index 9540119eae..e14727bc49 100644 --- a/testsuite/tests/safeHaskell/ghci/p16.stderr +++ b/testsuite/tests/safeHaskell/ghci/p16.stderr @@ -2,14 +2,14 @@ <no location info>: warning:
-XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving
-<interactive>:16:29: error:
+<interactive>:15:29: error:
Can't make a derived instance of ‘Op T2’:
‘Op’ is not a derivable class
Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension
In the newtype declaration for ‘T2’
-<interactive>:19:9: error:
+<interactive>:18:9: error:
Data constructor not in scope: T2 :: T -> t
- Perhaps you meant ‘T1’ (line 13)
+ Perhaps you meant ‘T1’ (line 12)
-<interactive>:22:4: error: Variable not in scope: y
+<interactive>:21:4: error: Variable not in scope: y
diff --git a/testsuite/tests/safeHaskell/ghci/p4.stderr b/testsuite/tests/safeHaskell/ghci/p4.stderr index 2160c00d7d..5d70969f3a 100644 --- a/testsuite/tests/safeHaskell/ghci/p4.stderr +++ b/testsuite/tests/safeHaskell/ghci/p4.stderr @@ -1,8 +1,8 @@ -<interactive>:6:9: error:
+<interactive>:5:9: error:
Not in scope: ‘System.IO.Unsafe.unsafePerformIO’
-<interactive>:7:9: error:
+<interactive>:6:9: error:
Variable not in scope: x :: IO Integer -> t
-<interactive>:8:1: error: Variable not in scope: y
+<interactive>:7:1: error: Variable not in scope: y
diff --git a/testsuite/tests/safeHaskell/ghci/p6.stderr b/testsuite/tests/safeHaskell/ghci/p6.stderr index 83343029d4..8cca54eb2f 100644 --- a/testsuite/tests/safeHaskell/ghci/p6.stderr +++ b/testsuite/tests/safeHaskell/ghci/p6.stderr @@ -1,10 +1,10 @@ -<interactive>:12:1: error:
+<interactive>:11:1: error:
Unacceptable result type in foreign declaration:
Safe Haskell is on, all FFI imports must be in the IO monad
When checking declaration:
foreign import ccall safe "static sin" c_sin :: Double -> Double
-<interactive>:13:1: error:
+<interactive>:12:1: error:
Variable not in scope: c_sin :: Integer -> t
- Perhaps you meant ‘c_sin'’ (line 8)
+ Perhaps you meant ‘c_sin'’ (line 7)
diff --git a/testsuite/tests/safeHaskell/ghci/p9.stderr b/testsuite/tests/safeHaskell/ghci/p9.stderr index e20f84f241..5104dd6a96 100644 --- a/testsuite/tests/safeHaskell/ghci/p9.stderr +++ b/testsuite/tests/safeHaskell/ghci/p9.stderr @@ -1,2 +1,2 @@ -<interactive>:10:1: error: Variable not in scope: b
+<interactive>:9:1: error: Variable not in scope: b
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index a7460b0d14..7f43dafdc8 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -126,3 +126,9 @@ T8221: T5996: $(RM) -f T5996.o T5996.hi '$(TEST_HC)' $(TEST_HC_OPTS) -O -c T5996.hs -ddump-simpl -dsuppress-uniques -dsuppress-all | grep y2 + +T10083: + $(RM) -f T10083.o T10083.hi T10083.hi-boot T10083a.o T10083a.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083.hs-boot + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083.hs diff --git a/testsuite/tests/simplCore/should_compile/T10083.hs b/testsuite/tests/simplCore/should_compile/T10083.hs new file mode 100644 index 0000000000..df896e6dab --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T10083.hs @@ -0,0 +1,5 @@ +module T10083 where + import T10083a + data RSR = MkRSR SR + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) diff --git a/testsuite/tests/simplCore/should_compile/T10083.hs-boot b/testsuite/tests/simplCore/should_compile/T10083.hs-boot new file mode 100644 index 0000000000..3d3e4a1281 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T10083.hs-boot @@ -0,0 +1,3 @@ +module T10083 where + data RSR + eqRSR :: RSR -> RSR -> Bool diff --git a/testsuite/tests/simplCore/should_compile/T10083a.hs b/testsuite/tests/simplCore/should_compile/T10083a.hs new file mode 100644 index 0000000000..f4fd782a99 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T10083a.hs @@ -0,0 +1,4 @@ +module T10083a where + import {-# SOURCE #-} T10083 + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 diff --git a/testsuite/tests/simplCore/should_compile/T10181.hs b/testsuite/tests/simplCore/should_compile/T10181.hs new file mode 100644 index 0000000000..1983507cd2 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T10181.hs @@ -0,0 +1,3 @@ +module T10181 where + +t a = t a diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index 9515266807..374533605e 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -3,6 +3,7 @@ Result size of Tidy Core = {terms: 22, types: 10, coercions: 0} Rec { +-- RHS size: {terms: 10, types: 2, coercions: 0} T3717.$wfoo [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>] T3717.$wfoo = @@ -13,6 +14,7 @@ T3717.$wfoo = } end Rec } +-- RHS size: {terms: 10, types: 4, coercions: 0} foo [InlPrag=INLINE[0]] :: Int -> Int [GblId, Arity=1, diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index 3d236823a6..e74fa39cb5 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -3,6 +3,7 @@ Result size of Tidy Core = {terms: 26, types: 11, coercions: 0} Rec { +-- RHS size: {terms: 10, types: 2, coercions: 0} $wxs :: Int# -> () [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>] $wxs = @@ -13,6 +14,7 @@ $wxs = } end Rec } +-- RHS size: {terms: 14, types: 5, coercions: 0} foo [InlPrag=NOINLINE] :: Int -> () [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U(U)>] foo = diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index ee3418c5bf..6ad89470bb 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -3,6 +3,7 @@ Result size of Tidy Core = {terms: 54, types: 38, coercions: 0} Rec { +-- RHS size: {terms: 19, types: 5, coercions: 0} T4908.f_$s$wf [Occ=LoopBreaker] :: Int# -> Int -> Int# -> Bool [GblId, Arity=3, Caf=NoCafRefs, Str=DmdType <S,1*U><L,A><L,U>] T4908.f_$s$wf = @@ -17,6 +18,7 @@ T4908.f_$s$wf = } end Rec } +-- RHS size: {terms: 24, types: 13, coercions: 0} T4908.$wf [InlPrag=[0]] :: Int# -> (Int, Int) -> Bool [GblId, Arity=2, @@ -39,6 +41,7 @@ T4908.$wf = 0# -> True } +-- RHS size: {terms: 8, types: 6, coercions: 0} f [InlPrag=INLINE[0]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index faf513477d..3e140ddc92 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -2,14 +2,17 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 23, types: 11, coercions: 0} +-- RHS size: {terms: 2, types: 0, coercions: 0} lvl :: [Char] [GblId, Str=DmdType] lvl = unpackCString# "Too small"# +-- RHS size: {terms: 2, types: 1, coercions: 0} T4930.foo1 :: Int [GblId, Str=DmdType b] T4930.foo1 = error @ Int lvl +-- RHS size: {terms: 16, types: 5, coercions: 0} foo :: Int -> Int [GblId, Arity=1, diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index ec3c4b08fb..f7979075ac 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -2,6 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 36, types: 29, coercions: 0} +-- RHS size: {terms: 6, types: 3, coercions: 0} T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo [GblId[DataConWrapper], Arity=1, @@ -16,10 +17,12 @@ T7360.$WFoo3 = \ (dt [Occ=Once!] :: Int) -> case dt of _ [Occ=Dead] { I# dt [Occ=Once] -> T7360.Foo3 dt } +-- RHS size: {terms: 5, types: 2, coercions: 0} fun1 [InlPrag=NOINLINE] :: Foo -> () [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>] fun1 = \ (x :: Foo) -> case x of _ [Occ=Dead] { __DEFAULT -> () } +-- RHS size: {terms: 2, types: 0, coercions: 0} T7360.fun5 :: () [GblId, Str=DmdType, @@ -27,6 +30,7 @@ T7360.fun5 :: () WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] T7360.fun5 = fun1 T7360.Foo1 +-- RHS size: {terms: 2, types: 0, coercions: 0} T7360.fun4 :: Int [GblId, Caf=NoCafRefs, @@ -35,6 +39,7 @@ T7360.fun4 :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.fun4 = I# 0# +-- RHS size: {terms: 16, types: 12, coercions: 0} fun2 :: forall a. [a] -> ((), Int) [GblId, Arity=1, diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index 2600dd00ba..5216d1ed5f 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -2,6 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 23, types: 16, coercions: 0} +-- RHS size: {terms: 22, types: 14, coercions: 0} main :: IO () [GblId, Str=DmdType] main = diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index ee2f63170b..b675077fda 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -106,6 +106,10 @@ test('T4918', run_command, ['$MAKE -s --no-print-directory T4918']) +# This test flips too and fro about whether it passes +# I'm not sure why it is so delicate, but it greps the +# result of -ddump-simpl, which is never advertised to +# be very stable test('T4945', expect_broken(4945), run_command, @@ -214,3 +218,8 @@ test('T10176', only_ways(['optasm']), compile, ['']) test('T10180', only_ways(['optasm']), compile, ['']) test('T10602', only_ways(['optasm']), multimod_compile, ['T10602','-v0']) test('T10627', only_ways(['optasm']), compile, ['']) +test('T10181', [expect_broken(10181), only_ways(['optasm'])], compile, ['']) +test('T10083', + expect_broken(10083), + run_command, + ['$MAKE -s --no-print-directory T10083']) diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 4bc2226554..392d4fba73 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -2,12 +2,14 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 162, types: 61, coercions: 0} +-- RHS size: {terms: 2, types: 1, coercions: 0} Roman.foo3 :: Int [GblId, Str=DmdType b] Roman.foo3 = patError @ Int "spec-inline.hs:(19,5)-(29,25)|function go"# Rec { +-- RHS size: {terms: 55, types: 9, coercions: 0} Roman.foo_$s$wgo [Occ=LoopBreaker] :: Int# -> Int# -> Int# [GblId, Arity=2, Caf=NoCafRefs, Str=DmdType <L,U><L,U>] Roman.foo_$s$wgo = @@ -30,6 +32,7 @@ Roman.foo_$s$wgo = } end Rec } +-- RHS size: {terms: 74, types: 22, coercions: 0} Roman.$wgo [InlPrag=[0]] :: Maybe Int -> Maybe Int -> Int# [GblId, Arity=2, @@ -67,6 +70,7 @@ Roman.$wgo = } } +-- RHS size: {terms: 9, types: 5, coercions: 0} Roman.foo_go [InlPrag=INLINE[0]] :: Maybe Int -> Maybe Int -> Int [GblId, Arity=2, @@ -80,6 +84,7 @@ Roman.foo_go = \ (w :: Maybe Int) (w1 :: Maybe Int) -> case Roman.$wgo w w1 of ww { __DEFAULT -> I# ww } +-- RHS size: {terms: 2, types: 0, coercions: 0} Roman.foo2 :: Int [GblId, Caf=NoCafRefs, @@ -88,6 +93,7 @@ Roman.foo2 :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.foo2 = I# 6# +-- RHS size: {terms: 2, types: 1, coercions: 0} Roman.foo1 :: Maybe Int [GblId, Caf=NoCafRefs, @@ -96,6 +102,7 @@ Roman.foo1 :: Maybe Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.foo1 = Just @ Int Roman.foo2 +-- RHS size: {terms: 11, types: 4, coercions: 0} foo :: Int -> Int [GblId, Arity=1, diff --git a/testsuite/tests/th/T10620.hs b/testsuite/tests/th/T10620.hs new file mode 100644 index 0000000000..3fe2519891 --- /dev/null +++ b/testsuite/tests/th/T10620.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + putStrLn $([| 'a'# |] >>= stringE . show) + putStrLn $([| "abc"# |] >>= stringE . show) diff --git a/testsuite/tests/th/T10620.stdout b/testsuite/tests/th/T10620.stdout new file mode 100644 index 0000000000..a0415d2442 --- /dev/null +++ b/testsuite/tests/th/T10620.stdout @@ -0,0 +1,2 @@ +LitE (CharPrimL 'a') +LitE (StringPrimL [97,98,99]) diff --git a/testsuite/tests/th/T10638.hs b/testsuite/tests/th/T10638.hs new file mode 100644 index 0000000000..7dd17eba41 --- /dev/null +++ b/testsuite/tests/th/T10638.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import GHC.Exts + +{- + the prim and javascript calling conventions do not support + headers and the static keyword. +-} + +-- check that quasiquoting roundtrips succesfully and that the declaration +-- does not include the static keyword +test1 :: String +test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- + [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] + addTopDecls ds + case p of + "test1" -> return (LitE . stringL $ p) + _ -> error $ "unexpected value: " ++ show p + ) + +-- check that constructed prim imports with the static keyword are rejected +test2 :: String +test2 = $(do t <- [t| Int# -> Int# |] + cmm_test2 <- newName "cmm_test2" + addTopDecls + [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] + [| test1 |] + ) diff --git a/testsuite/tests/th/T10638.stderr b/testsuite/tests/th/T10638.stderr new file mode 100644 index 0000000000..3a626ce46a --- /dev/null +++ b/testsuite/tests/th/T10638.stderr @@ -0,0 +1,6 @@ + +T10638.hs:26:11: + ‘static test2’ is not a valid C identifier + When checking declaration: + foreign import prim safe "static static test2" cmm_test2 + :: Int# -> Int# diff --git a/testsuite/tests/th/T7276a.stdout b/testsuite/tests/th/T7276a.stdout index 6aad44f6d5..3e8c4878a8 100644 --- a/testsuite/tests/th/T7276a.stdout +++ b/testsuite/tests/th/T7276a.stdout @@ -1,5 +1,5 @@ -<interactive>:4:9: Warning: +<interactive>:3:9: Warning: Couldn't match type ‘[Dec]’ with ‘Exp’ Expected type: Q Exp Actual type: DecsQ @@ -8,7 +8,7 @@ <interactive>:1:1: Exception when trying to run compile-time code: - <interactive>:4:9: + <interactive>:3:9: Couldn't match type ‘[Dec]’ with ‘Exp’ Expected type: Q Exp Actual type: DecsQ diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index 1c0a217a05..98029ab3a8 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -4,9 +4,9 @@ TYPE CONSTRUCTORS data T (a :: k) COERCION AXIOMS Dependent modules: [] -Dependent packages: [array-0.5.1.0, deepseq-1.4.1.1, - pretty-1.1.2.0, base-4.8.2.0, ghc-prim-0.4.0.0, - integer-gmp-1.0.0.0, template-haskell-2.10.0.0] +Dependent packages: [pretty-1.1.2.0, deepseq-1.4.1.1, + array-0.5.1.0, base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0, + template-haskell-2.10.0.0] ==================== Typechecker ==================== diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 6c2453f488..9e8f92d53d 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -345,3 +345,5 @@ test('T10019', normal, ghci_script, ['T10019.script']) test('T10279', normal, compile_fail, ['-v0']) test('T10306', normal, compile, ['-v0']) test('T10596', normal, compile, ['-v0']) +test('T10620', normal, compile_and_run, ['-v0']) +test('T10638', normal, compile_fail, ['-v0']) diff --git a/testsuite/tests/typecheck/should_compile/T10632.hs b/testsuite/tests/typecheck/should_compile/T10632.hs new file mode 100644 index 0000000000..5c1a1778af --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T10632.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImplicitParams #-} + +f :: (?file1 :: String) => IO () +f = putStrLn $ "f2: " + +main :: IO () +main = let ?file1 = "A" in f diff --git a/testsuite/tests/typecheck/should_compile/T10632.stderr b/testsuite/tests/typecheck/should_compile/T10632.stderr new file mode 100644 index 0000000000..81377b3364 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T10632.stderr @@ -0,0 +1,4 @@ + +T10632.hs:3:6: warning: + Redundant constraint: ?file1::String + In the type signature for: f :: (?file1::String) => IO () diff --git a/testsuite/tests/typecheck/should_compile/T2497.hs b/testsuite/tests/typecheck/should_compile/T2497.hs index 24933e086f..87b717ddbe 100644 --- a/testsuite/tests/typecheck/should_compile/T2497.hs +++ b/testsuite/tests/typecheck/should_compile/T2497.hs @@ -14,9 +14,13 @@ foo x = x -- Trac #2213; eq should not be reported as unused eq,beq :: Eq a => a -> a -> Bool +{-# NOINLINE [0] eq #-} +-- The pragma and [~1] in the RULE are to prevent an infinite loo +-- in the simplifier, where the RULE fires infinitely in its +-- own RHS eq = (==) -- Used beq = (==) -- Unused {-# RULES - "rule 1" forall x y. x == y = y `eq` x + "rule 1" [~1] forall x y. x == y = y `eq` x #-} diff --git a/testsuite/tests/typecheck/should_compile/T2497.stderr b/testsuite/tests/typecheck/should_compile/T2497.stderr index cd7ad8bc20..da730a05aa 100644 --- a/testsuite/tests/typecheck/should_compile/T2497.stderr +++ b/testsuite/tests/typecheck/should_compile/T2497.stderr @@ -1,2 +1,2 @@ -T2497.hs:18:1: Warning: Defined but not used: ‘beq’ +T2497.hs:22:1: warning: Defined but not used: ‘beq’ diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index a277b33b3a..db9ad0e657 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -165,7 +165,7 @@ test('tc161', normal, compile, ['']) test('tc162', normal, compile, ['']) test('tc163', normal, compile, ['']) test('tc164', normal, compile, ['']) -test('tc165', normal, compile, ['']) +test('tc165', expect_broken_for(10181, ['optasm', 'optllvm']), compile, ['']) test('tc166', normal, compile, ['']) test('tc167', normal, compile_fail, ['']) test('tc168', normal, compile_fail, ['']) @@ -283,7 +283,7 @@ test('T2433', extra_clean(['T2433_Help.hi', 'T2433_Help.o']), multimod_compile, ['T2433', '-v0']) test('T2494', normal, compile_fail, ['']) test('T2494-2', normal, compile, ['']) -test('T2497', normal, compile, ['']) +test('T2497', expect_broken_for(10657, ['optasm', 'optllvm']), compile, ['']) # Omitting temporarily @@ -466,4 +466,5 @@ test('T10428', normal, compile, ['']) test('RepArrow', normal, compile, ['']) test('T10562', normal, compile, ['']) test('T10564', normal, compile, ['']) +test('T10632', normal, compile, ['']) test('T10642', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.hs new file mode 100644 index 0000000000..7317371e8e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.hs @@ -0,0 +1,4 @@ +type Foo = Int +type Bar = Bool + +main = print $ (1 :: Foo) == (False :: Bar) diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.stderr new file mode 100644 index 0000000000..0d5a9109a4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail1.stderr @@ -0,0 +1,11 @@ +ExpandSynsFail1.hs:4:31: error: + Couldn't match type ‘Bool’ with ‘Int’ + Expected type: Foo + Actual type: Bar + Type synonyms expanded: + Expected type: Int + Actual type: Bool + In the second argument of ‘(==)’, namely ‘(False :: Bar)’ + In the second argument of ‘($)’, namely + ‘(1 :: Foo) == (False :: Bar)’ + In the expression: print $ (1 :: Foo) == (False :: Bar) diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.hs new file mode 100644 index 0000000000..e9c79c8975 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.hs @@ -0,0 +1,19 @@ +-- In case of types with nested type synonyms, all synonyms should be expanded + +{-# LANGUAGE RankNTypes #-} + +import Control.Monad.ST + +type Foo = Int +type Bar = Bool + +type MyFooST s = ST s Foo +type MyBarST s = ST s Bar + +fooGen :: forall s . MyFooST s +fooGen = undefined + +barGen :: forall s . MyBarST s +barGen = undefined + +main = print (runST fooGen == runST barGen) diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr new file mode 100644 index 0000000000..6ded98e0bd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail2.stderr @@ -0,0 +1,9 @@ +ExpandSynsFail2.hs:19:37: error: + Couldn't match type ‘Int’ with ‘Bool’ + Expected type: ST s Foo + Actual type: MyBarST s + Type synonyms expanded: + Expected type: ST s Int + Actual type: ST s Bool + In the first argument of ‘runST’, namely ‘barGen’ + In the second argument of ‘(==)’, namely ‘runST barGen’ diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.hs new file mode 100644 index 0000000000..31afaf21b9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.hs @@ -0,0 +1,23 @@ +-- We test two things here: +-- +-- 1. We expand only as much as necessary. In this case, we shouldn't expand T. +-- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion +-- e.g. we don't expand both of them to T1, instead we expand T5 to T3. + +module Main where + +type T5 = T4 +type T4 = T3 +type T3 = T2 +type T2 = T1 +type T1 = Int + +type T a = Int -> Bool -> a -> String + +f :: T (T3, T5, Int) -> Int +f = undefined + +a :: Int +a = f (undefined :: T (T5, T3, Bool)) + +main = print a diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.stderr new file mode 100644 index 0000000000..65d91351f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail3.stderr @@ -0,0 +1,11 @@ +ExpandSynsFail3.hs:21:8: error: + Couldn't match type ‘Int’ with ‘Bool’ + Expected type: T (T3, T5, Int) + Actual type: T (T5, T3, Bool) + Type synonyms expanded: + Expected type: T (T3, T3, Int) + Actual type: T (T3, T3, Bool) + In the first argument of ‘f’, namely + ‘(undefined :: T (T5, T3, Bool))’ + In the expression: f (undefined :: T (T5, T3, Bool)) + In an equation for ‘a’: a = f (undefined :: T (T5, T3, Bool)) diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.hs b/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.hs new file mode 100644 index 0000000000..1007594920 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.hs @@ -0,0 +1,11 @@ +-- Synonyms shouldn't be expanded since type error is visible without +-- expansions. Error message should not have `Type synonyms expanded: ...` part. + +module Main where + +type T a = [a] + +f :: T Int -> String +f = undefined + +main = putStrLn $ f (undefined :: T Bool) diff --git a/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.stderr b/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.stderr new file mode 100644 index 0000000000..bae53ce104 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExpandSynsFail4.stderr @@ -0,0 +1,7 @@ +ExpandSynsFail4.hs:11:22: error: + Couldn't match type ‘Bool’ with ‘Int’ + Expected type: T Int + Actual type: T Bool + In the first argument of ‘f’, namely ‘(undefined :: T Bool)’ + In the second argument of ‘($)’, namely ‘f (undefined :: T Bool)’ + In the expression: putStrLn $ f (undefined :: T Bool) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index a0a98e7e87..fbbeddbbe0 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -246,6 +246,7 @@ test('tcfail219', normal, multimod_compile_fail, ['tcfail219.hsig', '-sig-of "Sh test('tcfail220', normal, multimod_compile_fail, ['tcfail220.hsig', '-sig-of "ShouldFail is base:Prelude"']) test('tcfail221', normal, multimod_compile_fail, ['tcfail221.hsig', '-sig-of "ShouldFail is base:Prelude"']) test('tcfail222', normal, multimod_compile_fail, ['tcfail222.hsig', '-sig-of "ShouldFail is base:Data.STRef"']) +test('tcfail223', normal, compile_fail, ['']) test('SilentParametersOverlapping', normal, compile, ['']) test('FailDueToGivenOverlapping', normal, compile_fail, ['']) @@ -368,3 +369,8 @@ test('T10351', normal, compile_fail, ['']) test('T10534', extra_clean(['T10534a.hi', 'T10534a.o']), multimod_compile_fail, ['T10534', '-v0']) test('T10495', normal, compile_fail, ['']) + +test('ExpandSynsFail1', normal, compile_fail, ['-fprint-expanded-synonyms']) +test('ExpandSynsFail2', normal, compile_fail, ['-fprint-expanded-synonyms']) +test('ExpandSynsFail3', normal, compile_fail, ['-fprint-expanded-synonyms']) +test('ExpandSynsFail4', normal, compile_fail, ['-fprint-expanded-synonyms']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail223.hs b/testsuite/tests/typecheck/should_fail/tcfail223.hs new file mode 100644 index 0000000000..e5e0d5c8f8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail223.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +module ShouldFail where + +class Class1 a +class Class1 a => Class2 a +class Class2 a => Class3 a + +-- This was wrongfully accepted by ghc-7.0 to ghc-7.10. +-- It is missing a `Class1 a` constraint. +instance Class3 a => Class2 a diff --git a/testsuite/tests/typecheck/should_fail/tcfail223.stderr b/testsuite/tests/typecheck/should_fail/tcfail223.stderr new file mode 100644 index 0000000000..e4a4fcda54 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail223.stderr @@ -0,0 +1,9 @@ + +tcfail223.hs:10:10: error: + Could not deduce (Class1 a) + arising from the superclasses of an instance declaration + from the context: Class3 a + bound by the instance declaration at tcfail223.hs:10:10-29 + Possible fix: + add (Class1 a) to the context of the instance declaration + In the instance declaration for ‘Class2 a’ diff --git a/testsuite/tests/typecheck/should_run/T3500a.hs b/testsuite/tests/typecheck/should_run/T3500a.hs index c3adeb0c61..b614008ad4 100644 --- a/testsuite/tests/typecheck/should_run/T3500a.hs +++ b/testsuite/tests/typecheck/should_run/T3500a.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Main where diff --git a/testsuite/tests/typecheck/should_run/T5751.hs b/testsuite/tests/typecheck/should_run/T5751.hs index 423a40736d..7c7d8ab0b9 100644 --- a/testsuite/tests/typecheck/should_run/T5751.hs +++ b/testsuite/tests/typecheck/should_run/T5751.hs @@ -25,7 +25,7 @@ main = class (Widgets x) => MonadRender x class (XMLGenerator m) => Widgets m -- instance Widgets (IdentityT IO) -- if you uncomment this, it will work -instance MonadRender m => Widgets m +instance (XMLGenerator m, MonadRender m) => Widgets m instance MonadRender (IdentityT IO) web :: ( MonadIO m diff --git a/testsuite/tests/typecheck/should_run/T7126.hs b/testsuite/tests/typecheck/should_run/T7126.hs index ce9792de37..184d5df1f0 100644 --- a/testsuite/tests/typecheck/should_run/T7126.hs +++ b/testsuite/tests/typecheck/should_run/T7126.hs @@ -24,7 +24,7 @@ class Class2 a => Class3 a where instance Class1 Int where func1 = id -instance Class3 a => Class2 a where +instance (Class1 a, Class3 a) => Class2 a where func2 = func3 instance Class3 Int where diff --git a/testsuite/tests/typecheck/should_run/T7861.hs b/testsuite/tests/typecheck/should_run/T7861.hs index 9ff9a43604..19a9c9d1fe 100644 --- a/testsuite/tests/typecheck/should_run/T7861.hs +++ b/testsuite/tests/typecheck/should_run/T7861.hs @@ -1,20 +1,22 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# OPTIONS_GHC -fdefer-type-errors #-} module Main where -type A a = forall b. a - -doA :: A a -> [a] +doA :: (forall b. a) -> [a] doA = undefined -f :: A a -> a +f :: (forall b. a) -> a f = doA main = do { print "Hello 1" ; f `seq` print "Hello 2" -- The casts are pushed inside the lambda - -- for f, so this seq succeds fine + -- for f, so this seq succeeds fine + -- It does require ImpredicativeTypes, because we instantiate + -- seq's type (c->d->d) with f's type (c:= (forall b. a) -> a), + -- which is polymorphic (it has foralls). ; f (error "urk") `seq` print "Bad" -- But when we *call* f we get a type error diff --git a/testsuite/tests/typecheck/should_run/T7861.stderr b/testsuite/tests/typecheck/should_run/T7861.stderr index f9f238605e..62b0dcda34 100644 --- a/testsuite/tests/typecheck/should_run/T7861.stderr +++ b/testsuite/tests/typecheck/should_run/T7861.stderr @@ -1,10 +1,11 @@ -T7861: T7861.hs:11:5: +T7861: T7861.hs:10:5: error: Couldn't match type ‘a’ with ‘[a]’ - ‘a’ is a rigid type variable bound by - the type signature for: f :: A a -> a at T7861.hs:10:6 - Expected type: A a -> a - Actual type: A a -> [a] - Relevant bindings include f :: A a -> a (bound at T7861.hs:11:1) + ‘a’ is a rigid type variable bound by + the type signature for: f :: (forall b. a) -> a at T7861.hs:9:6 + Expected type: (forall b. a) -> a + Actual type: (forall b. a) -> [a] + Relevant bindings include + f :: (forall b. a) -> a (bound at T7861.hs:10:1) In the expression: doA In an equation for ‘f’: f = doA (deferred type error) diff --git a/testsuite/tests/typecheck/should_run/T9497a-run.stderr b/testsuite/tests/typecheck/should_run/T9497a-run.stderr index 192f78f6a2..43f720be7e 100644 --- a/testsuite/tests/typecheck/should_run/T9497a-run.stderr +++ b/testsuite/tests/typecheck/should_run/T9497a-run.stderr @@ -1,5 +1,5 @@ -T9497a-run: T9497a-run.hs:2:8: - Found hole ‘_main’ with type: IO () +T9497a-run: T9497a-run.hs:2:8: error: + Found hole: _main :: IO () Or perhaps ‘_main’ is mis-spelled, or not in scope Relevant bindings include main :: IO () (bound at T9497a-run.hs:2:1) diff --git a/testsuite/tests/typecheck/should_run/T9497b-run.stderr b/testsuite/tests/typecheck/should_run/T9497b-run.stderr index a53262e17d..02fda3473c 100644 --- a/testsuite/tests/typecheck/should_run/T9497b-run.stderr +++ b/testsuite/tests/typecheck/should_run/T9497b-run.stderr @@ -1,5 +1,5 @@ -T9497b-run: T9497b-run.hs:2:8: - Found hole ‘_main’ with type: IO () +T9497b-run: T9497b-run.hs:2:8: error: + Found hole: _main :: IO () Or perhaps ‘_main’ is mis-spelled, or not in scope Relevant bindings include main :: IO () (bound at T9497b-run.hs:2:1) diff --git a/testsuite/tests/typecheck/should_run/T9497c-run.stderr b/testsuite/tests/typecheck/should_run/T9497c-run.stderr index f991cd6c44..5fe0743d6c 100644 --- a/testsuite/tests/typecheck/should_run/T9497c-run.stderr +++ b/testsuite/tests/typecheck/should_run/T9497c-run.stderr @@ -1,5 +1,5 @@ -T9497c-run: T9497c-run.hs:2:8: - Found hole ‘_main’ with type: IO () +T9497c-run: T9497c-run.hs:2:8: error: + Found hole: _main :: IO () Or perhaps ‘_main’ is mis-spelled, or not in scope Relevant bindings include main :: IO () (bound at T9497c-run.hs:2:1) diff --git a/testsuite/tests/warnings/should_compile/DeprM.hs b/testsuite/tests/warnings/should_compile/DeprM.hs new file mode 100644 index 0000000000..2a84622e21 --- /dev/null +++ b/testsuite/tests/warnings/should_compile/DeprM.hs @@ -0,0 +1,4 @@ +module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where + +f :: Int +f = 42 diff --git a/testsuite/tests/warnings/should_compile/DeprU.hs b/testsuite/tests/warnings/should_compile/DeprU.hs new file mode 100644 index 0000000000..d15a7c51f7 --- /dev/null +++ b/testsuite/tests/warnings/should_compile/DeprU.hs @@ -0,0 +1,6 @@ +module A where + +import DeprM -- here should be emitted deprecation warning + +g :: Int +g = f diff --git a/testsuite/tests/warnings/should_compile/DeprU.stderr b/testsuite/tests/warnings/should_compile/DeprU.stderr new file mode 100644 index 0000000000..c27dccb474 --- /dev/null +++ b/testsuite/tests/warnings/should_compile/DeprU.stderr @@ -0,0 +1,10 @@ +[1 of 2] Compiling DeprM ( DeprM.hs, DeprM.o ) +[2 of 2] Compiling A ( DeprU.hs, DeprU.o ) + +DeprU.hs:3:1: Warning: + Module ‘DeprM’ is deprecated: + Here can be your menacing deprecation warning! + +DeprU.hs:6:5: Warning: + In the use of ‘f’ (imported from DeprM): + Deprecated: "Here can be your menacing deprecation warning!" diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T index 7fa8caf584..bbf5d1cc85 100644 --- a/testsuite/tests/warnings/should_compile/all.T +++ b/testsuite/tests/warnings/should_compile/all.T @@ -4,3 +4,9 @@ test('T9178', extra_clean(['T9178.o', 'T9178DataType.o', 'T9178.hi', 'T9178DataType.hi']), multimod_compile, ['T9178', '-Wall']) test('T9230', normal, compile_without_flag('-fno-warn-tabs'), ['']) + +test('DeprU', + extra_clean([ + 'DeprM.o', 'DeprU.o', + 'DeprM.hi', 'DeprU.hi']), + multimod_compile, ['DeprU', '-Wall']) diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs index f78baa10ea..3532497eef 100644 --- a/testsuite/timeout/timeout.hs +++ b/testsuite/timeout/timeout.hs @@ -33,8 +33,8 @@ main = do _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds") _ -> die ("Bad arguments " ++ show args) -timeoutMsg :: String -timeoutMsg = "Timeout happened...killing process..." +timeoutMsg :: String -> String +timeoutMsg cmd = "Timeout happened...killing process "++cmd++"..." run :: Int -> String -> IO () #if !defined(mingw32_HOST_OS) @@ -61,7 +61,7 @@ run secs cmd = do r <- takeMVar m case r of Nothing -> do - hPutStrLn stderr timeoutMsg + hPutStrLn stderr (timeoutMsg cmd) killProcess pid exitWith (ExitFailure 99) Just (Exited r) -> exitWith r @@ -122,7 +122,7 @@ run secs cmd = let millisecs = secs * 1000 rc <- waitForSingleObject handle (fromIntegral millisecs) if rc == cWAIT_TIMEOUT - then do hPutStrLn stderr timeoutMsg + then do hPutStrLn stderr (timeoutMsg cmd) terminateJobObject job 99 exitWith (ExitFailure 99) else alloca $ \p_exitCode -> diff --git a/testsuite/timeout/timeout.py b/testsuite/timeout/timeout.py index df50806b9b..1016e2db33 100644 --- a/testsuite/timeout/timeout.py +++ b/testsuite/timeout/timeout.py @@ -35,7 +35,8 @@ try: else: # parent def handler(signum, frame): - sys.stderr.write('Timeout happened...killing process...\n') + msg = 'Timeout happened...killing process %s...\n' % cmd + sys.stderr.write(msg) killProcess(pid) sys.exit(99) old = signal.signal(signal.SIGALRM, handler) diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index ed57fb8105..206b676031 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -292,21 +292,22 @@ fixupPackageId ipinfos (InstalledPackageId ipi) -- On Windows we need to split the ghc package into 2 pieces, or the -- DLL that it makes contains too many symbols (#5987). There are -- therefore 2 libraries, not just the 1 that Cabal assumes. -mangleLbi :: FilePath -> FilePath -> LocalBuildInfo -> LocalBuildInfo -mangleLbi "compiler" "stage2" lbi +mangleIPI :: FilePath -> FilePath -> LocalBuildInfo + -> Installed.InstalledPackageInfo -> Installed.InstalledPackageInfo +mangleIPI "compiler" "stage2" lbi ipi | isWindows = - let ccs' = [ (cn, updateComponentLocalBuildInfo clbi, cns) - | (cn, clbi, cns) <- componentsConfigs lbi ] - updateComponentLocalBuildInfo clbi@(LibComponentLocalBuildInfo {}) - = let cls' = concat [ [ LibraryName n, LibraryName (n ++ "-0") ] - | LibraryName n <- componentLibraries clbi ] - in clbi { componentLibraries = cls' } - updateComponentLocalBuildInfo clbi = clbi - in lbi { componentsConfigs = ccs' } + -- Cabal currently only ever installs ONE Haskell library, c.f. + -- the code in Cabal.Distribution.Simple.Register. If it + -- ever starts installing more we'll have to find the + -- library that's too big and split that. + let [old_hslib] = Installed.hsLibraries ipi + in ipi { + Installed.hsLibraries = [old_hslib, old_hslib ++ "-0"] + } where isWindows = case hostPlatform lbi of Platform _ Windows -> True _ -> False -mangleLbi _ _ lbi = lbi +mangleIPI _ _ _ ipi = ipi generate :: FilePath -> FilePath -> String -> [String] -> IO () generate directory distdir dll0Modules config_args @@ -318,9 +319,8 @@ generate directory distdir dll0Modules config_args withArgs (["configure", "--distdir", distdir] ++ config_args) runDefaultMain - lbi0 <- getPersistBuildConfig distdir - let lbi = mangleLbi directory distdir lbi0 - pd0 = localPkgDescr lbi + lbi <- getPersistBuildConfig distdir + let pd0 = localPkgDescr lbi writePersistBuildConfig distdir lbi @@ -345,7 +345,7 @@ generate directory distdir dll0Modules config_args let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace") let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir pd ipid lib lbi clbi - final_ipi = installedPkgInfo { + final_ipi = mangleIPI directory distdir lbi $ installedPkgInfo { Installed.installedPackageId = ipid, Installed.haddockHTMLs = [] } @@ -405,9 +405,7 @@ generate directory distdir dll0Modules config_args dep_ipids = map (display . Installed.installedPackageId) dep_direct depLibNames | packageKeySupported comp - = map (\p -> packageKeyLibraryName - (Installed.sourcePackageId p) - (Installed.packageKey p)) dep_direct + = map (display . Installed.libraryName) dep_direct | otherwise = deps depNames = map (display . packageName) dep_ids @@ -415,9 +413,7 @@ generate directory distdir dll0Modules config_args transitiveDeps = map display transitive_dep_ids transitiveDepLibNames | packageKeySupported comp - = map (\p -> packageKeyLibraryName - (Installed.sourcePackageId p) - (Installed.packageKey p)) dep_pkgs + = map (display . Installed.libraryName) dep_pkgs | otherwise = transitiveDeps transitiveDepNames = map (display . packageName) transitive_dep_ids @@ -437,9 +433,10 @@ generate directory distdir dll0Modules config_args otherMods = map display (otherModules bi) allMods = mods ++ otherMods let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), - variablePrefix ++ "_PACKAGE_KEY = " ++ display (pkgKey lbi), + -- TODO: move inside withLibLBI + variablePrefix ++ "_PACKAGE_KEY = " ++ display (localPackageKey lbi), -- copied from mkComponentsLocalBuildInfo - variablePrefix ++ "_LIB_NAME = " ++ packageKeyLibraryName (package pd) (pkgKey lbi), + variablePrefix ++ "_LIB_NAME = " ++ display (localLibraryName lbi), variablePrefix ++ "_MODULES = " ++ unwords mods, variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods, variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd, @@ -18,18 +18,20 @@ Flags: compiler the test suite covers. 2008-07-01: 63% slower than the default. HTML generated here: testsuite/hpc_output/hpc_index.html - --normal Default settings --fast Omit dyn way, omit binary distribution --slow Build stage2 with -DDEBUG. Skips tests that call - `compiler_stats_num_field`. + compiler_stats_num_field. 2008-07-01: 14% slower than the default. - --dph: Also build libraries/dph and run associated tests. + --dph Also build libraries/dph and run associated tests. + --quiet More pretty build log. + See Note [Default build system verbosity]. --help shows this usage help. - Set environment variable 'CPUS' to number of cores, to exploit - multiple cpu cores, e.g. + validate runs 'make -j\$THREADS', where by default THREADS is the number of + cpus your computer has +1. You can set the environment variable THREADS to + override this. For a sequential build you would for example use - CPUS=8 ./validate + THREADS=1 ./validate EOF } @@ -59,7 +61,7 @@ do --fast) speed=FAST ;; - --normal) + --normal) # for backward compat speed=NORMAL ;; --no-dph) # for backward compat @@ -120,8 +122,6 @@ detect_cpu_count () { # nothing helped CPUS="1" fi - - echo "using ${CPUS} CPUs" >&2 } detect_cpu_count @@ -138,11 +138,18 @@ else threads="$THREADS" fi +echo "using THREADS=${threads}" >&2 + if type gmake > /dev/null 2> /dev/null then - make="gmake -s" + make="gmake" else - make="make -s" + make="make" +fi + +if [ $be_quiet -eq 1 ]; then + # See Note [Default build system verbosity]. + make="$make -s" fi if [ $testsuite_only -eq 0 ]; then @@ -169,7 +176,21 @@ thisdir=`utils/ghc-pwd/dist-boot/ghc-pwd` echo "Validating=YES" > mk/are-validating.mk echo "ValidateSpeed=$speed" >> mk/are-validating.mk echo "ValidateHpc=$hpc" >> mk/are-validating.mk -echo "V=0" >> mk/are-validating.mk # Less gunk + +# Note [Default build system verbosity]. +# +# From https://ghc.haskell.org/trac/ghc/wiki/Design/BuildSystem: +# +# "The build system should clearly report what it's doing (and sometimes +# why), without being too verbose. It should emit actual command lines as +# much as possible, so that they can be inspected and cut & pasted." +# +# That should be the default. Only suppress commands, by setting V=0 and using +# `make -s`, when user explicitly asks for it with `./validate --quiet`. +if [ $be_quiet -eq 1 ]; then + # See Note [Default build system verbosity]. + echo "V=0" >> mk/are-validating.mk # Less gunk +fi if [ $speed != "FAST" ]; then # Build the "extra" packages (see ./packages), to enable more tests. |