diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -22,7 +22,6 @@ -- * GHC Monad Ghc, GhcT, GhcMonad(..), HscEnv, runGhc, runGhcT, initGhcMonad, - gcatch, gbracket, gfinally, printException, handleSourceError, needsTemplateHaskellOrQQ, @@ -179,7 +178,7 @@ isRecordSelector, isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, + isDeadEndId, isDictonaryId, recordSelectorTyCon, -- ** Type constructors @@ -291,7 +290,7 @@ * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt. -} -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude hiding (init) @@ -378,6 +377,7 @@ import System.FilePath import Control.Concurrent import Control.Applicative ((<|>)) +import Control.Monad.Catch as MC import GHC.Data.Maybe import System.IO.Error ( isDoesNotExistError ) @@ -400,7 +400,7 @@ => FatalMessager -> FlushOut -> m a -> m a defaultErrorHandler fm (FlushOut flushOut) inner = -- top-level exception handler: any unrecognised exception is a compiler bug. - ghandle (\exception -> liftIO $ do + MC.handle (\exception -> liftIO $ do flushOut case fromException exception of -- an IO exception probably isn't our fault, so don't panic @@ -437,7 +437,7 @@ {-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a defaultCleanupHandler _ m = m - where _warning_suppression = m `gonException` undefined + where _warning_suppression = m `MC.onException` undefined -- %************************************************************************ @@ -483,7 +483,7 @@ withCleanupSession ghct withCleanupSession :: GhcMonad m => m a -> m a -withCleanupSession ghc = ghc `gfinally` cleanup +withCleanupSession ghc = ghc `MC.finally` cleanup where cleanup = do hsc_env <- getSession @@ -597,8 +597,7 @@ setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags - dflags'' <- liftIO $ interpretPackageEnv dflags' - (dflags''', preload) <- liftIO $ initPackages dflags'' + (dflags''', preload) <- liftIO $ initPackages dflags' -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags @@ -611,7 +610,7 @@ | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 - then return (logInfo dflags (defaultDumpStyle dflags) msg) + then return (logInfo dflags $ withPprStyle defaultDumpStyle msg) else return (pure ()) let conf = IServConfig @@ -715,8 +714,12 @@ parseDynamicFlags :: MonadIO m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlags = parseDynamicFlagsCmdLine +parseDynamicFlags dflags cmdline = do + (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline + dflags2 <- liftIO $ interpretPackageEnv dflags1 + return (dflags2, leftovers, warns) + -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). @@ -1343,7 +1346,7 @@ -- ----------------------------------------------------------------------------- -{- ToDo: Move the primary logic here to compiler/main/Packages.hs +{- ToDo: Move the primary logic here to "GHC.Unit.State" -- | Return all /external/ modules available in the package database. -- Modules from the current session (i.e., from the 'HomePackageTable') are -- not included. This includes module names which are reexported by packages. @@ -1698,7 +1701,7 @@ getEnvVar :: MaybeT IO String getEnvVar = do - mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" + mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT" case mvar of Right var -> return var Left err -> if isDoesNotExistError err then mzero diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -105,6 +105,9 @@ numTyLitName, strTyLitName, -- TyVarBndr plainTVName, kindedTVName, + plainInvisTVName, kindedInvisTVName, + -- Specificity + specifiedSpecName, inferredSpecName, -- Role nominalRName, representationalRName, phantomRName, inferRName, -- Kind @@ -152,7 +155,7 @@ expQTyConName, fieldExpTyConName, predTyConName, stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrTyConName, clauseTyConName, + typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, patQTyConName, funDepTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, @@ -471,6 +474,15 @@ plainTVName = libFun (fsLit "plainTV") plainTVIdKey kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +plainInvisTVName, kindedInvisTVName :: Name +plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey +kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey + +-- data Specificity = ... +specifiedSpecName, inferredSpecName :: Name +specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey +inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey + -- data Role = ... nominalRName, representationalRName, phantomRName, inferRName :: Name nominalRName = libFun (fsLit "nominalR") nominalRIdKey @@ -546,7 +558,8 @@ conTyConName, bangTypeTyConName, varBangTypeTyConName, typeQTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, - derivClauseTyConName, kindTyConName, tyVarBndrTyConName, + derivClauseTyConName, kindTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, derivStrategyTyConName :: Name -- These are only used for the types of top-level splices expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -564,7 +577,8 @@ roleTyConName = libTc (fsLit "Role") roleTyConKey derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey kindTyConName = thTc (fsLit "Kind") kindTyConKey -tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey +tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey -- quasiquoting @@ -628,7 +642,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, patTyConKey, stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, - tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, + tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, + decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, @@ -655,7 +670,8 @@ funDepTyConKey = mkPreludeTyConUnique 222 predTyConKey = mkPreludeTyConUnique 223 predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrTyConKey = mkPreludeTyConUnique 225 +tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225 +tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 decsQTyConKey = mkPreludeTyConUnique 226 ruleBndrTyConKey = mkPreludeTyConUnique 227 tySynEqnTyConKey = mkPreludeTyConUnique 228 @@ -985,6 +1001,10 @@ plainTVIdKey = mkPreludeMiscIdUnique 413 kindedTVIdKey = mkPreludeMiscIdUnique 414 +plainInvisTVIdKey, kindedInvisTVIdKey :: Unique +plainInvisTVIdKey = mkPreludeMiscIdUnique 482 +kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 + -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique nominalRIdKey = mkPreludeMiscIdUnique 415 @@ -1059,6 +1079,11 @@ anyclassStrategyIdKey = mkPreludeDataConUnique 495 newtypeStrategyIdKey = mkPreludeDataConUnique 496 viaStrategyIdKey = mkPreludeDataConUnique 497 + +-- data Specificity = ... +specifiedSpecKey, inferredSpecKey :: Unique +specifiedSpecKey = mkPreludeMiscIdUnique 498 +inferredSpecKey = mkPreludeMiscIdUnique 499 {- ************************************************************************ diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -45,7 +45,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -127,7 +127,7 @@ all_names = -- We exclude most tuples from this list—see -- Note [Infinite families of known-key names] in GHC.Builtin.Names. - -- We make an exception for Unit (i.e., the boxed 1-tuple), since it does + -- We make an exception for Solo (i.e., the boxed 1-tuple), since it does -- not use special syntax like other tuples. -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) -- in GHC.Builtin.Types. diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -13,7 +13,7 @@ iNTERP_STACK_CHECK_THRESH ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -7,7 +7,7 @@ -- | Generate infotables for interpreter-made bytecodes module GHC.ByteCode.InfoTable ( mkITbls ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -9,7 +9,7 @@ BCInstr(..), ProtoBCO(..), bciStackUse, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -16,7 +16,7 @@ nameToCLabel, linkFail ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -176,6 +176,7 @@ ] +-- See Note [Primop wrappers] in GHC.Builtin.PrimOps primopToCLabel :: PrimOp -> String -> String primopToCLabel primop suffix = concat [ "ghczmprim_GHCziPrimopWrappers_" diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -31,7 +31,7 @@ stdPtrsOffset, stdNonPtrsOffset, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -459,7 +459,7 @@ type CAFEnv = LabelMap CAFSet mkCAFLabel :: CLabel -> CAFLabel -mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl +mkCAFLabel lbl = CAFLabel (toClosureLbl lbl) -- This is a label that we can put in an SRT. It *must* be a closure label, -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR. @@ -736,10 +736,11 @@ type SRTMap = Map CAFLabel (Maybe SRTEntry) --- | Given SRTMap of a module returns the set of non-CAFFY names in the module. --- Any Names not in the set are CAFFY. -srtMapNonCAFs :: SRTMap -> NameSet -srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap)) +-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the +-- module. Any 'Name's not in the set are CAFFY. +srtMapNonCAFs :: SRTMap -> NonCaffySet +srtMapNonCAFs srtMap = + NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap)) where get_name (CAFLabel l, Nothing) = hasHaskellName l get_name (_l, Just _srt_entry) = Nothing diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -357,10 +357,9 @@ -- This doesn't seem right somehow. We need to find out whether this -- proc will push some update frame material at some point, so that we --- can avoid using that area of the stack for spilling. The --- updfr_space field of the CmmProc *should* tell us, but it doesn't --- (I think maybe it gets filled in later when we do proc-point --- splitting). +-- can avoid using that area of the stack for spilling. Ideally we would +-- capture this information in the CmmProc (e.g. in CmmStackInfo; see #18232 +-- for details on one ill-fated attempt at this). -- -- So we'll just take the max of all the cml_ret_offs. This could be -- unnecessarily pessimistic, but probably not in the code we diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -69,6 +69,7 @@ MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to) MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) + MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to) _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op @@ -76,6 +77,7 @@ -- Eliminate conversion NOPs cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -- Eliminate nested conversions where possible cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -261,7 +261,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Char8 as BS8 -#include "HsVersions.h" +#include "GhclibHsVersions.h" } %expect 0 diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -368,6 +368,6 @@ -- If `-ddump-cmm-verbose -ddump-to-file` is specified, -- dump each Cmm pipeline stage output to a separate file. #16930 when (dopt Opt_D_dump_cmm_verbose dflags) - $ dumpAction dflags (mkDumpStyle dflags alwaysQualify) + $ dumpAction dflags (mkDumpStyle alwaysQualify) (dumpOptionsFromFlag flag) txt fmt sdoc dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs --- a/compiler/GHC/Cmm/Ppr.hs +++ b/compiler/GHC/Cmm/Ppr.hs @@ -103,9 +103,8 @@ -- Outputting types Cmm contains pprStackInfo :: CmmStackInfo -> SDoc -pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = - text "arg_space: " <> ppr arg_space <+> - text "updfr_space: " <> ppr updfr_space +pprStackInfo (StackInfo {arg_space=arg_space}) = + text "arg_space: " <> ppr arg_space pprTopInfo :: CmmTopInfo -> SDoc pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -356,7 +356,6 @@ g' = replacePPIds g live = ppLiveness (g_entry g') stack_info = StackInfo { arg_space = 0 - , updfr_space = Nothing , do_layout = True } -- cannot use panic, this is printed by -ddump-cmm diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -46,9 +46,6 @@ baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, currentTSOExpr, currentNurseryExpr, cccsExpr, - -- Statics - blankWord, - -- Tagging cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmConstrTag1, @@ -380,9 +377,6 @@ -> CmmLit (CmmInt (-n) rep) e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e] -blankWord :: Platform -> CmmStatic -blankWord platform = CmmUninitialised (platformWordSizeInBytes platform) - cmmToWord :: Platform -> CmmExpr -> CmmExpr cmmToWord platform e | w == word = e @@ -548,7 +542,7 @@ -- have both true and false successors. Block ordering can make a big difference -- in performance in the LLVM backend. Note that we rely crucially on the order -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode --- defined in cmm/CmmNode.hs. -GBM +-- defined in "GHC.Cmm.Node". -GBM toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] toBlockListEntryFirstFalseFallthrough g | mapNull m = [] diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -28,7 +28,7 @@ , x86NcgImpl ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -62,7 +62,7 @@ import GHC.CmmToAsm.Reg.Target import GHC.Platform import GHC.CmmToAsm.BlockLayout as BlockLayout -import Config +import GHC.Settings.Config import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.Platform.Reg @@ -390,7 +390,7 @@ $ makeImportsDoc dflags (concat (ngs_imports ngs)) return us' where - dump_stats = dumpAction dflags (mkDumpStyle dflags alwaysQualify) + dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify) (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" FormatText @@ -728,7 +728,7 @@ let optimizedCFG :: Maybe CFG optimizedCFG = - optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG + optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -13,7 +13,7 @@ ( sequenceTop, backendMaintainsCfg) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.CmmToAsm.Instr @@ -240,9 +240,46 @@ Assuming that Lwork is large the chance that the "call" ends up in the same cache line is also fairly small. --} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~ Note [Layout relevant edge weights] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The input to the chain based code layout algorithm is a CFG + with edges annotated with their frequency. The frequency + of traversal corresponds quite well to the cost of not placing + the connected blocks next to each other. + However even if having the same frequency certain edges are + inherently more or less relevant to code layout. + + In particular: + + * Edges which cross an info table are less relevant than others. + + If we place the blocks across this edge next to each other + they are still separated by the info table which negates + much of the benefit. It makes it less likely both blocks + will share a cache line reducing the benefits from locality. + But it also prevents us from eliminating jump instructions. + + * Conditional branches and switches are slightly less relevant. + + We can completely remove unconditional jumps by placing them + next to each other. This is not true for conditional branch edges. + We apply a small modifier to them to ensure edges for which we can + eliminate the overhead completely are considered first. See also #18053. + + * Edges constituted by a call are ignored. + + Considering these hardly helped with performance and ignoring + them helps quite a bit to improve compiler performance. + + So we perform a preprocessing step where we apply a multiplicator + to these kinds of edges. + + -} + + -- | Look at X number of blocks in two chains to determine -- if they are "neighbours". neighbourOverlapp :: Int @@ -636,35 +673,35 @@ -> [GenBasicBlock i] -- ^ Blocks placed in sequence. sequenceChain _info _weights [] = [] sequenceChain _info _weights [x] = [x] -sequenceChain info weights' blocks@((BasicBlock entry _):_) = - let weights :: CFG - weights = --pprTrace "cfg'" (pprEdgeWeights cfg') - cfg' - where - (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} mkGlobalWeights entry weights' - cfg' = {-# SCC rewriteEdges #-} - mapFoldlWithKey - (\cfg from m -> - mapFoldlWithKey - (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to ) - cfg m ) - weights' - globalEdgeWeights - - directEdges :: [CfgEdge] +sequenceChain info weights blocks@((BasicBlock entry _):_) = + let directEdges :: [CfgEdge] directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights) where + -- Apply modifiers to turn edge frequencies into useable weights + -- for computing code layout. + -- See also Note [Layout relevant edge weights] relevantWeight :: CfgEdge -> Maybe CfgEdge relevantWeight edge@(CfgEdge from to edgeInfo) | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo - -- Ignore edges across calls + -- Ignore edges across calls. = Nothing | mapMember to info , w <- edgeWeight edgeInfo - -- The payoff is small if we jump over an info table + -- The payoff is quite small if we jump over an info table = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 }) + | (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo + , cantEliminate exitNode + , w <- edgeWeight edgeInfo + -- A small penalty to edge types which + -- we can't optimize away by layout. + -- w * 0.96875 == w - w/32 + = Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 }) | otherwise = Just edge + where + cantEliminate CmmCondBranch {} = True + cantEliminate CmmSwitch {} = True + cantEliminate _ = False blockMap :: LabelMap (GenBasicBlock i) blockMap diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -42,7 +42,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -670,11 +670,21 @@ typedEdges = classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)] +optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG +optimizeCFG _ _ (CmmData {}) cfg = cfg +optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg = + (if doStaticPred then staticPredCfg (g_entry graph) else id) $ + optHsPatterns weights proc $ cfg -optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG -optimizeCFG _ (CmmData {}) cfg = cfg -optimizeCFG weights (CmmProc info _lab _live graph) cfg = - {-# SCC optimizeCFG #-} +-- | Modify branch weights based on educated guess on +-- patterns GHC tends to produce and how they affect +-- performance. +-- +-- Most importantly we penalize jumps across info tables. +optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG +optHsPatterns _ (CmmData {}) cfg = cfg +optHsPatterns weights (CmmProc info _lab _live graph) cfg = + {-# SCC optHsPatterns #-} -- pprTrace "Initial:" (pprEdgeWeights cfg) $ -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $ @@ -749,6 +759,21 @@ | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True | otherwise = False +-- | Convert block-local branch weights to global weights. +staticPredCfg :: BlockId -> CFG -> CFG +staticPredCfg entry cfg = cfg' + where + (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} + mkGlobalWeights entry cfg + cfg' = {-# SCC rewriteEdges #-} + mapFoldlWithKey + (\cfg from m -> + mapFoldlWithKey + (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to ) + cfg m ) + cfg + globalEdgeWeights + -- | Determine loop membership of blocks based on SCC analysis -- This is faster but only gives yes/no answers. loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool @@ -922,6 +947,10 @@ -- reverse post order. Which is required for diamond control flow to work probably. -- -- We also apply a few prediction heuristics (based on the same paper) +-- +-- The returned result represents frequences. +-- For blocks it's the expected number of executions and +-- for edges is the number of traversals. {-# NOINLINE mkGlobalWeights #-} {-# SCC mkGlobalWeights #-} diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -5,9 +5,9 @@ import GHC.Prelude import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) -import Config ( cProjectName, cProjectVersion ) -import GHC.Core ( Tickish(..) ) +import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Settings.Config ( cProjectName, cProjectVersion ) +import GHC.Core ( Tickish(..) ) import GHC.Cmm.DebugBlock import GHC.Driver.Session import GHC.Unit.Module diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -37,7 +37,10 @@ -- (for allocation purposes, anyway). -- data RegUsage - = RU [Reg] [Reg] + = RU { + reads :: [Reg], + writes :: [Reg] + } -- | No regs read or written to. noUsage :: RegUsage diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -44,7 +44,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -682,7 +682,6 @@ -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ - text ".section \".toc\", \"aw\"", text ".LC_" <> pprCLabel dflags lbl <> char ':', text "\t.quad" <+> pprCLabel dflags lbl ] _ -> empty @@ -845,4 +844,3 @@ initializePicBase_x86 _ _ _ _ = panic "initializePicBase_x86: not needed" - diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -20,7 +20,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" -- NCG stuff: import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/PPC/Cond.hs b/compiler/GHC/CmmToAsm/PPC/Cond.hs --- a/compiler/GHC/CmmToAsm/PPC/Cond.hs +++ b/compiler/GHC/CmmToAsm/PPC/Cond.hs @@ -2,8 +2,6 @@ Cond(..), condNegate, condUnsigned, - condToSigned, - condToUnsigned, ) where @@ -47,17 +45,3 @@ condUnsigned GEU = True condUnsigned LEU = True condUnsigned _ = False - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -10,7 +10,7 @@ -- ----------------------------------------------------------------------------- -#include "HsVersions.h" +#include "GhclibHsVersions.h" module GHC.CmmToAsm.PPC.Instr ( archWordFormat, diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -86,8 +86,13 @@ pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> ppr lbl <> text ", .-" <> ppr lbl + then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl else empty + where + prettyLbl = ppr lbl + codeLbl + | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl + | otherwise = prettyLbl pprFunctionDescriptor :: CLabel -> SDoc pprFunctionDescriptor lab = pprGloblDecl lab diff --git a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs --- a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs @@ -17,7 +17,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -48,7 +48,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -554,8 +554,9 @@ delAssoc a m | Just aSet <- lookupUFM m a , m1 <- delFromUFM m a - = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet - -- It's OK to use nonDetFoldUFM here because deletion is commutative + = nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet + -- It's OK to use a non-deterministic fold here because deletion is + -- commutative | otherwise = m diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -6,7 +6,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -101,7 +102,7 @@ module GHC.CmmToAsm.Reg.Linear.Stats ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -137,6 +138,7 @@ import Data.Maybe import Data.List import Control.Monad +import Control.Applicative -- ----------------------------------------------------------------------------- -- Top level of the register allocator @@ -229,8 +231,13 @@ go f = linearRegAlloc' config f entry_ids block_live sccs platform = ncgPlatform config +-- | Constraints on the instruction instances used by the +-- linear allocator. +type OutputableRegConstraint freeRegs instr = + (FR freeRegs, Outputable freeRegs, Outputable instr, Instruction instr) + linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) + :: OutputableRegConstraint freeRegs instr => NCGConfig -> freeRegs -> [BlockId] -- ^ entry points @@ -246,7 +253,7 @@ return (blocks, stats, getStackUse stack) -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) +linearRA_SCCs :: OutputableRegConstraint freeRegs instr => [BlockId] -> BlockMap RegSet -> [NatBasicBlock instr] @@ -281,7 +288,7 @@ more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, Outputable instr) +process :: OutputableRegConstraint freeRegs instr => [BlockId] -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] @@ -325,15 +332,18 @@ -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) + :: OutputableRegConstraint freeRegs instr => BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated processBlock block_live (BasicBlock id instrs) - = do initBlock id block_live + = do -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs) + initBlock id block_live + (instrs', fixups) <- linearRA block_live [] [] id instrs + -- pprTraceM "blockResult" $ ppr (instrs', fixups) return $ BasicBlock id instrs' : fixups @@ -369,7 +379,7 @@ -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) + :: OutputableRegConstraint freeRegs instr => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. @@ -396,7 +406,7 @@ -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) + :: OutputableRegConstraint freeRegs instr => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging @@ -476,7 +486,7 @@ | otherwise = False -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) +genRaInsn :: OutputableRegConstraint freeRegs instr => BlockMap RegSet -> [instr] -> BlockId @@ -486,6 +496,7 @@ -> RegM freeRegs ([instr], [NatBasicBlock instr]) genRaInsn block_live new_instrs block_id instr r_dying w_dying = do +-- pprTraceM "genRaInsn" $ ppr (block_id, instr) platform <- getPlatform case regUsageOfInstr platform instr of { RU read written -> do @@ -525,6 +536,8 @@ (fixup_blocks, adjusted_instr) <- joinToTargets block_live block_id instr +-- when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks + -- Debugging - show places where the reg alloc inserted -- assignment fixup blocks. -- when (not $ null fixup_blocks) $ @@ -737,7 +750,7 @@ -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) + :: forall freeRegs instr. (FR freeRegs, Outputable instr, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns @@ -749,7 +762,8 @@ = return (spills, reverse alloc) allocateRegsAndSpill reading keep spills alloc (r:rs) - = do assig <- getAssigR + = do assig <- getAssigR :: RegM freeRegs (RegMap Loc) + -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig) let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register @@ -779,6 +793,26 @@ | otherwise -> doSpill WriteNew +-- | Given a virtual reg find a preferred real register. +-- The preferred register is simply the first one the variable +-- was assigned to (if any). This way when we allocate for a loop +-- variables are likely to end up in the same registers at the +-- end and start of the loop, avoiding redundant reg-reg moves. +-- Note: I tried returning a list of past assignments, but that +-- turned out to barely matter but added a few tenths of +-- a percent to compile time. +findPrefRealReg :: forall freeRegs u. Uniquable u + => u -> RegM freeRegs (Maybe RealReg) +findPrefRealReg vreg = do + bassig <- getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc)) + return $ foldr (findVirtRegAssig) Nothing bassig + where + findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg + findVirtRegAssig assig z = + z <|> case lookupUFM (snd assig) vreg of + Just (InReg real_reg) -> Just real_reg + Just (InBoth real_reg _) -> Just real_reg + _ -> z -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY @@ -795,18 +829,26 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = do platform <- getPlatform freeRegs <- getFreeRegsR - let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs + let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg] - case freeRegs_thisClass of + -- Can we put the variable into a register it already was? + pref_reg <- findPrefRealReg r + case freeRegs_thisClass of -- case (2): we have a free register - (my_reg : _) -> - do spills' <- loadTemp r spill_loc my_reg spills + (first_free : _) -> + do let final_reg + | Just reg <- pref_reg + , reg `elem` freeRegs_thisClass + = reg + | otherwise + = first_free + spills' <- loadTemp r spill_loc final_reg spills - setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) - setFreeRegsR $ frAllocateReg platform my_reg freeRegs + setAssigR (addToUFM assig r $! newLocation spill_loc final_reg) + setFreeRegsR $ frAllocateReg platform final_reg freeRegs - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs -- case (3): we need to push something out to free up a register @@ -814,7 +856,8 @@ do let inRegOrBoth (InReg _) = True inRegOrBoth (InBoth _ _) = True inRegOrBoth _ = False - let candidates' = + let candidates' :: UniqFM Loc + candidates' = flip delListFromUFM keep $ filterUFM inRegOrBoth $ assig diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -30,6 +30,7 @@ import GHC.Types.Unique.Supply import GHC.Cmm.BlockId +data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) -- | Used to store the register assignment on entry to a basic block. -- We use this to handle join points, where multiple branch instructions @@ -138,6 +139,8 @@ , ra_config :: !NCGConfig -- | (from,fixup,to) : We inserted fixup code between from and to - , ra_fixups :: [(BlockId,BlockId,BlockId)] } + , ra_fixups :: [(BlockId,BlockId,BlockId)] + + } diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -5,7 +5,7 @@ maxSpillSlots ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" where diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | Free regs map for PowerPC module GHC.CmmToAsm.Reg.Linear.PPC where @@ -26,6 +28,9 @@ data FreeRegs = FreeRegs !Word32 !Word32 deriving( Show ) -- The Show is used in an ASSERT + +instance Outputable FreeRegs where + ppr = text . show noFreeRegs :: FreeRegs noFreeRegs = FreeRegs 0 0 diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Free regs map for SPARC module GHC.CmmToAsm.Reg.Linear.SPARC where @@ -37,6 +38,9 @@ instance Show FreeRegs where show = showFreeRegs + +instance Outputable FreeRegs where + ppr = text . showFreeRegs -- | A reg map where no regs are free to be allocated. noFreeRegs :: FreeRegs diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Free regs map for i386 module GHC.CmmToAsm.Reg.Linear.X86 where @@ -9,12 +10,13 @@ import GHC.Platform.Reg import GHC.Utils.Panic import GHC.Platform +import GHC.Utils.Outputable import Data.Word import Data.Bits newtype FreeRegs = FreeRegs Word32 - deriving Show + deriving (Show,Outputable) noFreeRegs :: FreeRegs noFreeRegs = FreeRegs 0 diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Free regs map for x86_64 module GHC.CmmToAsm.Reg.Linear.X86_64 where @@ -9,12 +10,13 @@ import GHC.Platform.Reg import GHC.Utils.Panic import GHC.Platform +import GHC.Utils.Outputable import Data.Word import Data.Bits newtype FreeRegs = FreeRegs Word64 - deriving Show + deriving (Show,Outputable) noFreeRegs :: FreeRegs noFreeRegs = FreeRegs 0 diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -19,7 +19,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/SPARC/Base.hs b/compiler/GHC/CmmToAsm/SPARC/Base.hs --- a/compiler/GHC/CmmToAsm/SPARC/Base.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Base.hs @@ -3,7 +3,7 @@ -- Also import the required constants, so we know what we're using. -- -- In the interests of cross-compilation, we want to free ourselves --- from the autoconf generated modules like main/Constants +-- from the autoconf generated modules like "GHC.Settings.Constants" module GHC.CmmToAsm.SPARC.Base ( wordLength, diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -17,7 +17,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" -- NCG stuff: import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/SPARC/Cond.hs b/compiler/GHC/CmmToAsm/SPARC/Cond.hs --- a/compiler/GHC/CmmToAsm/SPARC/Cond.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Cond.hs @@ -1,8 +1,5 @@ module GHC.CmmToAsm.SPARC.Cond ( Cond(..), - condUnsigned, - condToSigned, - condToUnsigned ) where @@ -28,27 +25,3 @@ | VC | VS deriving Eq - - -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Instr.hs @@ -7,7 +7,7 @@ -- (c) The University of Glasgow 1993-2004 -- ----------------------------------------------------------------------------- -#include "HsVersions.h" +#include "GhclibHsVersions.h" module GHC.CmmToAsm.SPARC.Instr ( RI(..), diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -22,7 +22,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -33,7 +33,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" -- NCG stuff: import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/X86/Cond.hs b/compiler/GHC/CmmToAsm/X86/Cond.hs --- a/compiler/GHC/CmmToAsm/X86/Cond.hs +++ b/compiler/GHC/CmmToAsm/X86/Cond.hs @@ -1,7 +1,5 @@ module GHC.CmmToAsm.X86.Cond ( Cond(..), - condUnsigned, - condToSigned, condToUnsigned, maybeFlipCond, maybeInvertCond @@ -30,22 +28,6 @@ | PARITY | NOTPARITY deriving Eq - -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - condToUnsigned :: Cond -> Cond condToUnsigned GTT = GU diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -16,7 +16,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -20,7 +20,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/X86/RegInfo.hs b/compiler/GHC/CmmToAsm/X86/RegInfo.hs --- a/compiler/GHC/CmmToAsm/X86/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/X86/RegInfo.hs @@ -6,7 +6,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs --- a/compiler/GHC/CmmToAsm/X86/Regs.hs +++ b/compiler/GHC/CmmToAsm/X86/Regs.hs @@ -47,7 +47,7 @@ where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -23,7 +23,7 @@ writeC ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" -- Cmm stuff import GHC.Prelude @@ -129,6 +129,10 @@ pprDataExterns platform lits $$ pprWordArray dflags (isSecConstant section) lbl lits where + isSecConstant section = case sectionProtection section of + ReadOnlySection -> True + WriteProtectedSection -> True + _ -> False platform = targetPlatform dflags -- -------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -11,7 +11,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -32,13 +32,13 @@ llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR, - strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, + strCLabel_llvm, getGlobalPtr, generateExternDecls, aliasify, llvmDefLabel ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" #include "ghcautoconf.h" import GHC.Prelude @@ -512,32 +512,6 @@ str = Outp.renderWithStyle (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)) sdoc - return (fsLit str) - -strDisplayName_llvm :: CLabel -> LlvmM LMString -strDisplayName_llvm lbl = do - dflags <- getDynFlags - let sdoc = pprCLabel dflags lbl - depth = Outp.PartWay 1 - style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth - str = Outp.renderWithStyle (initSDocContext dflags style) sdoc - return (fsLit (dropInfoSuffix str)) - -dropInfoSuffix :: String -> String -dropInfoSuffix = go - where go "_info" = [] - go "_static_info" = [] - go "_con_info" = [] - go (x:xs) = x:go xs - go [] = [] - -strProcedureName_llvm :: CLabel -> LlvmM LMString -strProcedureName_llvm lbl = do - dflags <- getDynFlags - let sdoc = pprCLabel dflags lbl - depth = Outp.PartWay 1 - style = Outp.mkUserStyle dflags Outp.neverQualify depth - str = Outp.renderWithStyle (initSDocContext dflags style) sdoc return (fsLit str) -- ---------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -6,7 +6,7 @@ -- module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -7,7 +7,7 @@ genLlvmData, genData ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -83,7 +83,8 @@ Section CString _ -> if (platformArch platform == ArchS390X) then Just 2 else Just 1 _ -> Nothing - const = if isSecConstant sec then Constant else Global + const = if sectionProtection sec == ReadOnlySection + then Constant else Global varDef = LMGlobalVar label tyAlias link lmsec align const globDef = LMGlobal varDef struct diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs --- a/compiler/GHC/CmmToLlvm/Ppr.hs +++ b/compiler/GHC/CmmToLlvm/Ppr.hs @@ -7,7 +7,7 @@ pprLlvmCmmDecl, pprLlvmData, infoSection ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs --- a/compiler/GHC/CmmToLlvm/Regs.hs +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -9,7 +9,7 @@ stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -21,7 +21,7 @@ GHC.Core.Lint.dumpIfSet, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -63,8 +63,8 @@ import GHC.Utils.Misc import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) -import GHC.Core.Arity ( typeArity ) -import GHC.Types.Demand ( splitStrictSig, isBotDiv ) +import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv ) import GHC.Driver.Types import GHC.Driver.Session @@ -299,7 +299,7 @@ -> IO () dumpPassResult dflags unqual mb_flag hdr extra_info binds rules = do { forM_ mb_flag $ \flag -> do - let sty = mkDumpStyle dflags unqual + let sty = mkDumpStyle unqual dumpAction dflags sty (dumpOptionsFromFlag flag) (showSDoc dflags hdr) FormatCore dump_doc @@ -372,7 +372,7 @@ displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) + $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs , text "*** Offending Program ***" , pprCoreBindings binds @@ -385,7 +385,7 @@ -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) = putLogMsg dflags NoReason Err.SevInfo noSrcSpan - (defaultDumpStyle dflags) + $ withPprStyle defaultDumpStyle (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return () @@ -416,7 +416,8 @@ display_lint_err err = do { putLogMsg dflags NoReason Err.SevDump - noSrcSpan (defaultDumpStyle dflags) + noSrcSpan + $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" (text what) , err , text "*** Offending Program ***" @@ -461,7 +462,7 @@ addLoc TopLevelBindings $ do { checkL (null dups) (dupVars dups) ; checkL (null ext_dups) (dupExtVars ext_dups) - ; lintRecBindings TopLevel all_pairs $ + ; lintRecBindings TopLevel all_pairs $ \_ -> return () } where all_pairs = flattenBinds binds @@ -572,11 +573,11 @@ -} lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] - -> LintM a -> LintM a + -> ([LintedId] -> LintM a) -> LintM a lintRecBindings top_lvl pairs thing_inside = lintIdBndrs top_lvl bndrs $ \ bndrs' -> do { zipWithM_ lint_pair bndrs' rhss - ; thing_inside } + ; thing_inside bndrs' } where (bndrs, rhss) = unzip pairs lint_pair bndr' rhs @@ -584,6 +585,12 @@ do { rhs_ty <- lintRhs bndr' rhs -- Check the rhs ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty } +lintLetBody :: [LintedId] -> CoreExpr -> LintM LintedType +lintLetBody bndrs body + = do { body_ty <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) + ; mapM_ (lintJoinBndrType body_ty) bndrs + ; return body_ty } + lintLetBind :: TopLevelFlag -> RecFlag -> LintedId -> CoreExpr -> LintedType -> LintM () -- Binder's type, and the RHS, have already been linted @@ -650,7 +657,7 @@ ppr binder) ; case splitStrictSig (idStrictness binder) of - (demands, result_info) | isBotDiv result_info -> + (demands, result_info) | isDeadEndDiv result_info -> checkL (demands `lengthAtLeast` idArity binder) (text "idArity" <+> ppr (idArity binder) <+> text "exceeds arity imposed by the strictness signature" <+> @@ -658,7 +665,7 @@ ppr binder) _ -> return () - ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) ; addLoc (UnfoldingOf binder) $ lintIdUnfolding binder binder_ty (idUnfolding binder) } @@ -678,22 +685,9 @@ -- its OccInfo and join-pointer-hood lintRhs bndr rhs | Just arity <- isJoinId_maybe bndr - = lint_join_lams arity arity True rhs + = lintJoinLams arity (Just bndr) rhs | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = lint_join_lams arity arity False rhs - where - lint_join_lams 0 _ _ rhs - = lintCoreExpr rhs - - lint_join_lams n tot enforce (Lam var expr) - = lintLambda var $ lint_join_lams (n-1) tot enforce expr - - lint_join_lams n tot True _other - = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs - lint_join_lams _ _ False rhs - = markAllJoinsBad $ lintCoreExpr rhs - -- Future join point, not yet eta-expanded - -- Body is not a tail position + = lintJoinLams arity Nothing rhs -- Allow applications of the data constructor @StaticPtr@ at the top -- but produce errors otherwise. @@ -715,6 +709,22 @@ binders0 go _ = markAllJoinsBad $ lintCoreExpr rhs +-- | Lint the RHS of a join point with expected join arity of @n@ (see Note +-- [Join points] in GHC.Core). +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM LintedType +lintJoinLams join_arity enforce rhs + = go join_arity rhs + where + go 0 rhs = lintCoreExpr rhs + go n (Lam var expr) = lintLambda var $ go (n-1) expr + -- N.B. join points can be cast. e.g. we consider ((\x -> ...) `cast` ...) + -- to be a join point at join arity 1. + go n _other | Just bndr <- enforce -- Join point with too few RHS lambdas + = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs + | otherwise -- Future join point, not yet eta-expanded + = markAllJoinsBad $ lintCoreExpr rhs + -- Body of lambda is not a tail position + lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty uf | isStableUnfolding uf @@ -755,6 +765,40 @@ unfolding beforehand is merely an optimization, and one that actively hurts us here. +Note [Linting of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~ +runRW# has some very peculiar behavior (see Note [runRW magic] in +GHC.CoreToStg.Prep) which CoreLint must accommodate. + +As described in Note [Casts and lambdas] in +GHC.Core.Opt.Simplify.Utils, the simplifier pushes casts out of +lambdas. Concretely, the simplifier will transform + + runRW# @r @ty (\s -> expr `cast` co) + +into + + runRW# @r @ty ((\s -> expr) `cast` co) + +Consequently we need to handle the case that the continuation is a +cast of a lambda. See Note [Casts and lambdas] in +GHC.Core.Opt.Simplify.Utils. + +In the event that the continuation is headed by a lambda (which +will bind the State# token) we can safely allow calls to join +points since CorePrep is going to apply the continuation to +RealWorld. + +In the case that the continuation is not a lambda we lint the +continuation disallowing join points, to rule out things like, + + join j = ... + in runRW# @r @ty ( + let x = jump j + in x + ) + + ************************************************************************ * * \subsection[lintCoreExpr]{lintCoreExpr} @@ -769,6 +813,18 @@ type LintedTyCoVar = TyCoVar type LintedId = Id +-- | Lint an expression cast through the given coercion, returning the type +-- resulting from the cast. +lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType +lintCastExpr expr expr_ty co + = do { co' <- lintCoercion co + ; let (Pair from_ty to_ty, role) = coercionKindRole co' + ; checkValueType to_ty $ + text "target of cast" <+> quotes (ppr co') + ; lintRole co' Representational role + ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + lintCoreExpr :: CoreExpr -> LintM LintedType -- The returned type has the substitution from the monad -- already applied to it: @@ -786,14 +842,8 @@ = return (literalType lit) lintCoreExpr (Cast expr co) - = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr - ; co' <- lintCoercion co - ; let (Pair from_ty to_ty, role) = coercionKindRole co' - ; checkValueType to_ty $ - text "target of cast" <+> quotes (ppr co') - ; lintRole co' Representational role - ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } + = do expr_ty <- markAllJoinsBad $ lintCoreExpr expr + lintCastExpr expr expr_ty co lintCoreExpr (Tick tickish expr) = do case tickish of @@ -830,7 +880,7 @@ -- Now lint the binder ; lintBinder LetBind bndr $ \bndr' -> do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty - ; addLoc (BodyOfLetRec [bndr]) (lintCoreExpr body) } } + ; lintLetBody [bndr'] body } } | otherwise = failWithL (mkLetErr bndr rhs) -- Not quite accurate @@ -847,13 +897,37 @@ ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ mkInconsistentRecMsg bndrs - ; lintRecBindings NotTopLevel pairs $ - addLoc (BodyOfLetRec bndrs) $ - lintCoreExpr body } + ; lintRecBindings NotTopLevel pairs $ \ bndrs' -> + lintLetBody bndrs' body } where bndrs = map fst pairs lintCoreExpr e@(App _ _) + | Var fun <- fun + , fun `hasKey` runRWKey + -- N.B. we may have an over-saturated application of the form: + -- runRW (\s -> \x -> ...) y + , arg_ty1 : arg_ty2 : arg3 : rest <- args + = do { fun_ty1 <- lintCoreArg (idType fun) arg_ty1 + ; fun_ty2 <- lintCoreArg fun_ty1 arg_ty2 + -- See Note [Linting of runRW#] + ; let lintRunRWCont :: CoreArg -> LintM LintedType + lintRunRWCont (Cast expr co) = do + ty <- lintRunRWCont expr + lintCastExpr expr ty co + lintRunRWCont expr@(Lam _ _) = do + lintJoinLams 1 (Just fun) expr + lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other + -- TODO: Look through ticks? + ; arg3_ty <- lintRunRWCont arg3 + ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty + ; lintCoreArgs app_ty rest } + + | Var fun <- fun + , fun `hasKey` runRWKey + = failWithL (text "Invalid runRW# application") + + | otherwise = do { fun_ty <- lintCoreFun fun (length args) ; lintCoreArgs fun_ty args } where @@ -950,6 +1024,25 @@ = return () ------------------ +lintJoinBndrType :: LintedType -- Type of the body + -> LintedId -- Possibly a join Id + -> LintM () +-- Checks that the return type of a join Id matches the body +-- E.g. join j x = rhs in body +-- The type of 'rhs' must be the same as the type of 'body' +lintJoinBndrType body_ty bndr + | Just arity <- isJoinId_maybe bndr + , let bndr_ty = idType bndr + , (bndrs, res) <- splitPiTys bndr_ty + = checkL (length bndrs >= arity + && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ + hang (text "Join point returns different type than body") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Body type:" <+> ppr body_ty ]) + | otherwise + = return () + checkJoinOcc :: Id -> JoinArity -> LintM () -- Check that if the occurrence is a JoinId, then so is the -- binding site, and it's a valid join Id @@ -985,7 +1078,7 @@ * exprIsHNF is false: it would *seem* to be terribly wrong if the scrutinee was already in head normal form. -* exprIsBottom is true: we should be able to see why GHC believes the +* exprIsDeadEnd is true: we should be able to see why GHC believes the scrutinee is diverging for sure. It was already known that the second test was not entirely reliable. @@ -1114,11 +1207,15 @@ = failWithL (mkTyAppMsg fun_ty arg_ty) ----------------- + +-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ +-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the +-- application. lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType lintValApp arg fun_ty arg_ty - | Just (arg,res) <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg arg_ty err1 - ; return res } + | Just (arg_ty', res_ty') <- splitFunTy_maybe fun_ty + = do { ensureEqTys arg_ty' arg_ty err1 + ; return res_ty' } | otherwise = failWithL err2 where @@ -1181,7 +1278,7 @@ , isAlgTyCon tycon , not (isAbstractTyCon tycon) , null (tyConDataCons tycon) - , not (exprIsBottom scrut) + , not (exprIsDeadEnd scrut) -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) -- This can legitimately happen for type families $ return () @@ -1734,7 +1831,7 @@ Applying this rule can't turn a well-typed program into an ill-typed one, so conceivably we could allow it. But we can always eta-expand such an -"undersaturated" rule (see 'GHC.Core.Arity.etaExpandToJoinPointRule'), and in fact +"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact the simplifier would have to in order to deal with the RHS. So we take a conservative view and don't allow undersaturated rules for join points. See Note [Rules and join points] in OccurAnal for further discussion. @@ -1793,7 +1890,12 @@ = do { subst <- getTCvSubst ; case lookupCoVar subst cv of Just linted_co -> return linted_co ; - Nothing -> -- lintCoBndr always extends the substitition + Nothing + | cv `isInScope` subst + -> return (CoVarCo cv) + | otherwise + -> + -- lintCoBndr always extends the substitition failWithL $ hang (text "The coercion variable" <+> pprBndr LetBind cv) 2 (text "is out of scope") @@ -2292,6 +2394,7 @@ = RhsOf Id -- The variable bound | OccOf Id -- Occurrence of id | LambdaBodyOf Id -- The lambda-binder + | RuleOf Id -- Rules attached to a binder | UnfoldingOf Id -- Unfolding of a binder | BodyOfLetRec [Id] -- One of the binders | CaseAlt CoreAlt -- Case alternative @@ -2510,6 +2613,9 @@ dumpLoc (LambdaBodyOf b) = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) +dumpLoc (RuleOf b) + = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) + dumpLoc (UnfoldingOf b) = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) @@ -2751,11 +2857,11 @@ 2 (ppr var <+> dcolon <+> ppr ty) mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc -mkBadJoinArityMsg var ar nlams rhs +mkBadJoinArityMsg var ar n rhs = vcat [ text "Join point has too few lambdas", text "Join var:" <+> ppr var, text "Join arity:" <+> ppr ar, - text "Number of lambdas:" <+> ppr nlams, + text "Number of lambdas:" <+> ppr (ar - n), text "Rhs = " <+> ppr rhs ] @@ -2845,7 +2951,7 @@ when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat [ lint_banner "warning" pname , text "Core changes with annotations:" - , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs + , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs ] -- Return actual new guts return nguts diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -11,7 +11,7 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -16,7 +16,7 @@ import GHC.Types.Basic import GHC.Core import GHC.Types.Id -import GHC.Core.Arity ( typeArity ) +import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) import GHC.Data.Graph.UnVar import GHC.Types.Demand @@ -384,7 +384,7 @@ 1. We need to ensure the invariant callArity e <= typeArity (exprType e) for the same reasons that exprArity needs this invariant (see Note - [exprArity invariant] in GHC.Core.Arity). + [exprArity invariant] in GHC.Core.Opt.Arity). If we are not doing that, a too-high arity annotation will be stored with the id, confusing the simplifier later on. @@ -701,7 +701,7 @@ where max_arity_by_type = length (typeArity (idType v)) max_arity_by_strsig - | isBotDiv result_info = length demands + | isDeadEndDiv result_info = length demands | otherwise = a (demands, result_info) = splitStrictSig (idStrictness v) diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -9,7 +9,7 @@ -- See Note [Phase ordering]. module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -21,7 +21,6 @@ import GHC.Utils.Outputable import GHC.Types.Var.Env import GHC.Types.Basic -import Data.List import GHC.Core.DataCon import GHC.Types.Id import GHC.Types.Id.Info @@ -34,6 +33,9 @@ import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Maybe ( isJust, isNothing ) +import Control.Monad ( guard ) +import Data.List + {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that @@ -231,9 +233,14 @@ sig where sig - | isGlobalId id -- imported function or data con worker + -- See Note [CPR for expandable unfoldings] + | Just rhs <- cprExpandUnfolding_maybe id + = fst $ cprAnal env rhs + -- Imported function or data con worker + | isGlobalId id = getCprSig (idCprInfo id) - | Just sig <- lookupSigEnv env id -- local let-bound + -- Local let-bound + | Just sig <- lookupSigEnv env id = getCprSig sig | otherwise = topCprType @@ -303,6 +310,8 @@ | stays_thunk = trimCprTy rhs_ty -- See Note [CPR for sum types] | returns_sum = trimCprTy rhs_ty + -- See Note [CPR for expandable unfoldings] + | will_expand = topCprType | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' @@ -316,7 +325,16 @@ (_, ret_ty) = splitPiTys (idType id) not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) returns_sum = not (isTopLevel top_lvl) && not_a_prod + -- See Note [CPR for expandable unfoldings] + will_expand = isJust (cprExpandUnfolding_maybe id) +cprExpandUnfolding_maybe :: Id -> Maybe CoreExpr +cprExpandUnfolding_maybe id = do + guard (idArity id == 0) + -- There are only phase 0 Simplifier runs after CPR analysis + guard (isActiveIn 0 (idInlineActivation id)) + expandUnfolding_maybe (idUnfolding id) + {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Although it doesn't affect correctness of the analysis per se, we have to trim @@ -625,6 +643,48 @@ fac won't have the CPR property here when we trim every thunk! But the assumption is that error cases are rarely entered and we are diverging anyway, so WW doesn't hurt. + +Should we also trim CPR on DataCon application bindings? +See Note [CPR for expandable unfoldings]! + +Note [CPR for expandable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Long static data structures (whether top-level or not) like + + xs = x1 : xs1 + xs1 = x2 : xs2 + xs2 = x3 : xs3 + +should not get CPR signatures, because they + + * Never get WW'd, so their CPR signature should be irrelevant after analysis + (in fact the signature might even be harmful for that reason) + * Would need to be inlined/expanded to see their constructed product + * Recording CPR on them blows up interface file sizes and is redundant with + their unfolding. In case of Nested CPR, this blow-up can be quadratic! + +But we can't just stop giving DataCon application bindings the CPR property, +for example + + fac 0 = 1 + fac n = n * fac (n-1) + +fac certainly has the CPR property and should be WW'd! But FloatOut will +transform the first clause to + + lvl = 1 + fac 0 = lvl + +If lvl doesn't have the CPR property, fac won't either. But lvl doesn't have a +CPR signature to extrapolate into a CPR transformer ('cprTransform'). So +instead we keep on cprAnal'ing through *expandable* unfoldings for these arity +0 bindings via 'cprExpandUnfolding_maybe'. + +In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one +for each data declaration. It's wasteful to attach CPR signatures to each of +them (and intractable in case of Nested CPR). + +Tracked by #18154. Note [CPR examples] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -11,12 +11,12 @@ module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Driver.Session -import GHC.Core.Opt.WorkWrap.Utils ( findTypeShape ) +import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it import GHC.Core import GHC.Core.Seq ( seqBinds ) @@ -25,6 +25,7 @@ import GHC.Types.Basic import Data.List ( mapAccumL ) import GHC.Core.DataCon +import GHC.Types.ForeignCall ( isSafeForeignCall ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Utils @@ -34,7 +35,7 @@ import GHC.Core.FamInstEnv import GHC.Utils.Misc import GHC.Data.Maybe ( isJust ) -import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Types.Unique.Set @@ -151,7 +152,7 @@ dmdAnal' env d e dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) -dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co) = (unitDmdType (coercionDmdEnv co), Coercion co) @@ -222,8 +223,13 @@ (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 scrut dc bndrs = deferAfterIO alt_ty2 - | otherwise = alt_ty2 + fam_envs = ae_fam_envs env + alt_ty3 + -- See Note [Precise exceptions and strictness analysis] in Demand + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty2 + | otherwise + = alt_ty2 -- Compute demand on the scrutinee -- See Note [Demand on scrutinee of a product case] @@ -251,12 +257,20 @@ -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives - res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty + fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in Demand + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty + | otherwise + = alt_ty + res_ty = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty + in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_tys" <+> ppr alt_tys --- , text "alt_ty" <+> ppr alt_ty +-- , text "alt_ty2" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ (res_ty, Case scrut' case_bndr' ty alts') @@ -314,17 +328,38 @@ body_ty2 `seq` (body_ty2, Let (Rec pairs') body') -io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool --- See Note [IO hack in the demand analyser] -io_hack_reqd scrut con bndrs - | (bndr:_) <- bndrs - , con == tupleDataCon Unboxed 2 - , idType bndr `eqType` realWorldStatePrimTy - , (fun, _) <- collectArgs scrut - = case fun of - Var f -> not (isPrimOpId f) - _ -> True +-- | A simple, syntactic analysis of whether an expression MAY throw a precise +-- exception when evaluated. It's always sound to return 'True'. +-- See Note [Which scrutinees may throw precise exceptions]. +exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool +exprMayThrowPreciseException envs e + | not (forcesRealWorld envs (exprType e)) + = False -- 1. in the Note + | (Var f, _) <- collectArgs e + , Just op <- isPrimOpId_maybe f + , op /= RaiseIOOp + = False -- 2. in the Note + | (Var f, _) <- collectArgs e + , Just fcall <- isFCallId_maybe f + , not (isSafeForeignCall fcall) + = False -- 3. in the Note | otherwise + = True -- _. in the Note + +-- | Recognises types that are +-- * @State# RealWorld@ +-- * Unboxed tuples with a @State# RealWorld@ field +-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See +-- T13380e) and user-written variants thereof by their type. +forcesRealWorld :: FamInstEnvs -> Type -> Bool +forcesRealWorld fam_envs ty + | ty `eqType` realWorldStatePrimTy + = True + | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } + <- deepSplitProductType_maybe fam_envs ty + , isUnboxedTupleCon dc + = any (\(ty,_) -> ty `eqType` realWorldStatePrimTy) field_tys + | otherwise = False dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) @@ -340,49 +375,42 @@ id_dmds = addCaseBndrDmd case_bndr_dmd dmds = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) - -{- 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'? Often not! If foo x s performs some observable action -(including raising an exception with raiseIO#, modifying a mutable variable, or -even ending the program normally), then we must not force 'y' (which may fail -to terminate) until we have performed foo x s. - -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 +{- Note [Which scrutinees may throw precise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the specification of 'exprMayThrowPreciseExceptions', +which is important for Scenario 2 of +Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. -A more complete example (#148, #1592) where this shows up is: - do { let len = ; - ; when (...) (exitWith ExitSuccess) - ; print len } +For an expression @f a1 ... an :: ty@ we determine that + 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. + This check is done by 'forcesRealWorld'. + (Why not simply unboxed pairs as above? This is motivated by + T13380{d,e}.) + 2. False If f is a PrimOp, and it is *not* raiseIO# + 3. False If f is an unsafe FFI call ('PlayRisky') + _. True Otherwise "give up". -However, consider - f x s = case getMaskingState# s of - (# s, r #) -> - case x of I# x2 -> ... +It is sound to return False in those cases, because + 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions + from pure code. + 2. raiseIO# is the only primop that may throw a precise exception. + 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). + See haddock on GHC.Types.ForeignCall.PlayRisky. -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 made a material difference. +We *need* to return False in those cases, because + 1. We would lose too much strictness in pure code, all over the place. + 2. We would lose strictness for primops like getMaskingState#, which + introduces a substantial regression in + GHC.IO.Handle.Internals.wantReadableHandle. + 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + where an intermittent FFI call to c_MD5Init would otherwise lose + strictness on the arguments len and buf, leading to regressions in T9203 + (2%) and i386's haddock.base (5%). Tested by T13380f. -So if the scrutinee is a primop call, we *don't* apply the -state hack: - - If it 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 already 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. +In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) +to the Divergence lattice, but in practice it turned out to be hard to untaint +from 'topDiv' to 'conDiv', leading to bugs, performance regressions and +complexity that didn't justify the single fixed testcase T13380c. Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -453,27 +481,33 @@ -- this function plus demand on its free variables dmdTransform env var dmd - | isDataConWorkId var -- Data constructor + -- Data constructors + | isDataConWorkId var = dmdTransformDataConSig (idArity var) dmd - + -- Dictionary component selectors | gopt Opt_DmdTxDictSel (ae_dflags env), - Just _ <- isClassOpId_maybe var -- Dictionary component selector + Just _ <- isClassOpId_maybe var = dmdTransformDictSelSig (idStrictness var) dmd - - | isGlobalId var -- Imported function + -- Imported functions + | isGlobalId var , let res = dmdTransformSig (idStrictness var) dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) res - - | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing + -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). + -- In that case, we have a strictness signature to unleash in our AnalEnv. + | Just (sig, top_lvl) <- lookupSigEnv env var , let fn_ty = dmdTransformSig sig dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ + = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ if isTopLevel top_lvl - then fn_ty -- Don't record top level things + then fn_ty -- Don't record demand on top-level things else addVarDmd fn_ty var (mkOnceUsedDmd dmd) - - | otherwise -- Local non-letrec-bound thing - = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) + -- Everything else: + -- * Local let binders for which we use LetUp (cf. 'useLetUp') + -- * Lambda binders + -- * Case and constructor field binders + | otherwise + = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ + unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) {- ************************************************************************ @@ -600,10 +634,9 @@ = mkRhsDmd env rhs_arity rhs (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs - -- TODO: Won't the following line unnecessarily trim down arity for join - -- points returning a lambda in a C(S) context? - sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div) - id' = setIdStrictness id sig + sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) + id' = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $ + setIdStrictness id sig -- See Note [NOINLINE and strictness] @@ -847,9 +880,9 @@ no manifest lambdas, it won't do so automatically, and indeed 'co' might have type (Int->Int->Int) ~ T. -Fortunately, GHC.Core.Arity gives 'foo' arity 2, which is enough for LetDown to +Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to forward plusInt's demand signature, and all is well (see Note [Newtype arity] in -GHC.Core.Arity)! A small example is the test case NewtypeArity. +GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. Historical Note [Product demands for function body] diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs --- a/compiler/GHC/Core/Opt/Driver.hs +++ b/compiler/GHC/Core/Opt/Driver.hs @@ -8,7 +8,7 @@ module GHC.Core.Opt.Driver ( core2core, simplifyExpr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -495,7 +495,7 @@ ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn ++ (mg_rules guts) ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) + $ withPprStyle defaultDumpStyle (ruleCheckProgram current_phase pat rule_fn (mg_binds guts)) ; return guts } diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -18,7 +18,7 @@ module GHC.Core.Opt.FloatIn ( floatInwards ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform @@ -407,12 +407,17 @@ But there are wrinkles -* Which unlifted cases do we float? See GHC.Builtin.PrimOps - Note [PrimOp can_fail and has_side_effects] which explains: - - We can float-in can_fail primops, but we can't float them out. +* Which unlifted cases do we float? + See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which + explains: + - We can float in can_fail primops (which concerns imprecise exceptions), + but we can't float them out. - But we can float a has_side_effects primop, but NOT inside a lambda, - so for now we don't float them at all. - Hence exprOkForSideEffects + so for now we don't float them at all. Hence exprOkForSideEffects. + - Throwing precise exceptions is a special case of the previous point: We + may /never/ float in a call to (something that ultimately calls) + 'raiseIO#'. + See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. * Because we can float can-fail primops (array indexing, division) inwards but not outwards, we must be careful not to transform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -15,12 +15,12 @@ import GHC.Core import GHC.Core.Utils import GHC.Core.Make -import GHC.Core.Arity ( etaExpand ) +import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) -import GHC.Types.Id ( Id, idArity, idType, isBottomingId, +import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Core.Opt.SetLevels import GHC.Types.Unique.Supply ( UniqSupply ) @@ -33,7 +33,7 @@ import Data.List ( partition ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ----------------- @@ -221,8 +221,9 @@ -- A tiresome hack: -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels - let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' - | otherwise = rhs' + let rhs'' | isDeadEndId var + , exprArity rhs' < idArity var = etaExpand (idArity var) rhs' + | otherwise = rhs' in (fs, rhs_floats, [NonRec var rhs'']) } diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} module GHC.Core.Opt.LiberateCase ( liberateCase ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -158,8 +158,8 @@ Let (Rec dup_pairs) (Var unitDataConId) ok_pair (id,_) - = idArity id > 0 -- Note [Only functions!] - && not (isBottomingId id) -- Note [Not bottoming ids] + = idArity id > 0 -- Note [Only functions!] + && not (isDeadEndId id) -- Note [Not bottoming ids] {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -62,7 +62,7 @@ incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -74,7 +74,7 @@ , isExprLevPoly , collectMakeStaticArgs ) -import GHC.Core.Arity ( exprBotStrictness_maybe ) +import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) import GHC.Core.FVs -- all of it import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) @@ -83,19 +83,21 @@ import GHC.Types.Id.Info import GHC.Types.Var import GHC.Types.Var.Set -import GHC.Types.Unique.Set ( nonDetFoldUniqSet ) +import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) +import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Unique ( hasKey ) import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet ) import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Core.DataCon ( dataConOrigResTy ) import GHC.Builtin.Types +import GHC.Builtin.Names ( runRWKey ) import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Outputable @@ -293,7 +295,7 @@ lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr lvl_top env is_rec bndr rhs = lvlRhs env is_rec - (isBottomingId bndr) + (isDeadEndId bndr) Nothing -- Not a join point (freeVars rhs) @@ -399,8 +401,14 @@ lvlApp :: LevelEnv -> CoreExprWithFVs -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application - -> LvlM LevelledExpr -- Result expression + -> LvlM LevelledExpr -- Result expression lvlApp env orig_expr ((_,AnnVar fn), args) + -- Try to ensure that runRW#'s continuation isn't floated out. + -- See Note [Simplification of runRW#]. + | fn `hasKey` runRWKey + = do { args' <- mapM (lvlExpr env) args + ; return (foldl' App (lookupVar env fn) args') } + | floatOverSat env -- See Note [Floating over-saturated applications] , arity > 0 , arity < n_val_args @@ -943,7 +951,7 @@ Lint complains unless the scrutinee of such a case is clearly bottom. This was reported in #11290. But since the whole bottoming-float - thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure + thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure that it'll nail all such cases. Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] @@ -952,6 +960,9 @@ arity of the RHS should be the same as the arity; but we can't call etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut. +But we should only eta-expand if the RHS doesn't already have the right +exprArity, otherwise we get unnecessary top-level bindings if the RHS was +trivial after the next run of the Simplifier. Note [Case MFEs] ~~~~~~~~~~~~~~~~ @@ -983,7 +994,7 @@ = case mb_str of Nothing -> id Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (increaseStrictSigArity n_extra sig) + `setIdStrictness` (prependArgsStrictSig n_extra sig) `setIdCprInfo` mkCprSig (arity + n_extra) botCpr notWorthFloating :: CoreExpr -> [Var] -> Bool @@ -1469,8 +1480,8 @@ isFunction _ = False countFreeIds :: DVarSet -> Int -countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet - -- It's OK to use nonDetFoldUDFM here because we're just counting things. +countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet + -- It's OK to use nonDetStrictFoldUDFM here because we're just counting things. where add :: Var -> Int -> Int add v n | isId v = n+1 @@ -1581,12 +1592,14 @@ maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level maxFvLevel max_me env var_set - = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set + = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set + -- It's OK to use a non-deterministic fold here because maxIn commutes. maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level -- Same but for TyCoVarSet maxFvLevel' max_me env var_set - = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set + = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set + -- It's OK to use a non-deterministic fold here because maxIn commutes. maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -37,10 +37,13 @@ , StrictnessMark (..) ) import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) import GHC.Core +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey ) import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd , mkClosedStrictSig, topDmd, botDiv ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold import GHC.Core.Utils import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg @@ -785,7 +788,7 @@ possible. We use tryEtaExpandRhs on every binding, and it turns ou that the -arity computation it performs (via GHC.Core.Arity.findRhsArity) already +arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already does a simple bottoming-expression analysis. So all we need to do is propagate that info to the binder's IdInfo. @@ -1804,7 +1807,7 @@ log_inlining doc = liftIO $ dumpAction dflags - (mkUserStyle dflags alwaysQualify AllTheWay) + (mkUserStyle alwaysQualify AllTheWay) (dumpOptionsFromFlag Opt_D_dump_inlinings) "" FormatText doc @@ -1877,14 +1880,36 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) = rebuildCall env (addTyArgTo info arg_ty) cont -rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty +---------- The runRW# rule. Do this after absorbing all arguments ------ +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ]) +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont }) + | fun `hasKey` runRWKey + , not (contIsStop cont) -- Don't fiddle around if the continuation is boring + , [ TyArg {}, TyArg {} ] <- rev_args + = do { s <- newId (fsLit "s") realWorldStatePrimTy + ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s + , sc_env = env', sc_cont = cont } + ; body' <- simplExprC env' arg cont' + ; let arg' = Lam s body' + ty' = contResultType cont + rr' = getRuntimeRep ty' + call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg'] + ; return (emptyFloats env, call') } + +rebuildCall env info@(ArgInfo { ai_type = fun_ty, ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup_flag, sc_cont = cont }) + + -- Argument is already simplified | isSimplified dup_flag -- See Note [Avoid redundant simplification] = rebuildCall env (addValArgTo info' arg) cont - | str -- Strict argument + -- Strict arguments + | str , sm_case_case (getMode env) = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg @@ -1892,7 +1917,8 @@ , sc_dup = Simplified, sc_cont = cont }) -- Note [Shadowing] - | otherwise -- Lazy argument + -- Lazy arguments + | otherwise -- DO NOT float anything outside, hence simplExprC -- There is no benefit (unlike in a let-binding), and we'd -- have to be very careful about bogus strictness through @@ -2092,7 +2118,7 @@ log_rule dflags flag hdr details = liftIO $ do - let sty = mkDumpStyle dflags alwaysQualify + let sty = mkDumpStyle alwaysQualify dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ sep [text hdr, nest 4 details] @@ -3058,7 +3084,7 @@ | is_bot_alt alt = altsWouldDup alts | otherwise = not (all is_bot_alt alts) where - is_bot_alt (_,_,rhs) = exprIsBottom rhs + is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs ------------------------- mkDupableCont :: SimplEnv -> SimplCont @@ -3515,7 +3541,7 @@ -- we don't.) The simple thing is always to have one. where is_top_lvl = isTopLevel top_lvl - is_bottoming = isBottomingId id + is_bottoming = isDeadEndId id ------------------- simplStableUnfolding :: SimplEnv -> TopLevelFlag diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -43,7 +43,7 @@ wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -143,6 +143,7 @@ ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" FormatText (hang (text herald) 2 doc) } +{-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -36,7 +36,7 @@ isExitJoinId ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -49,7 +49,7 @@ import GHC.Core.TyCo.Ppr ( pprParendType ) import GHC.Core.FVs import GHC.Core.Utils -import GHC.Core.Arity +import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Types.Name import GHC.Types.Id @@ -58,7 +58,6 @@ import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic -import GHC.Builtin.PrimOps import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) @@ -499,11 +498,9 @@ -- interesting context. This avoids substituting -- top-level bindings for (say) strings into -- calls to error. But now we are more careful about - -- inlining lone variables, so it's ok - -- (see GHC.Core.Opt.Simplify.Utils.analyseCont) - -- See Note [Precise exceptions and strictness analysis] in Demand.hs - -- for the special case on raiseIO# - if isBotDiv result_info || isPrimOpId_maybe fun == Just RaiseIOOp then + -- inlining lone variables, so its ok + -- (see GHC.Core.Op.Simplify.Utils.analyseCont) + if isDeadEndDiv result_info then map isStrictDmd demands -- Finite => result is bottom else map isStrictDmd demands ++ vanilla_stricts @@ -833,6 +830,21 @@ Doing this to either side confounds tools like HERMIT, which seek to reason about and apply the RULES as originally written. See #10829. +There is, however, one case where we are pretty much /forced/ to transform the +LHS of a rule: postInlineUnconditionally. For instance, in the case of + + let f = g @Int in f + +We very much want to inline f into the body of the let. However, to do so (and +be able to safely drop f's binding) we must inline into all occurrences of f, +including those in the LHS of rules. + +This can cause somewhat surprising results; for instance, in #18162 we found +that a rule template contained ticks in its arguments, because +postInlineUnconditionally substituted in a trivial expression that contains +ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for +details. + Note [No eta expansion in stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have a stable unfolding @@ -1145,7 +1157,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env | not pre_inline_unconditionally = Nothing | not active = Nothing - | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids] + | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] -- in module Exitify @@ -1254,6 +1266,10 @@ with both a and b marked NOINLINE. But that seems incompatible with our new view that inlining is like a RULE, so I'm sticking to the 'active' story for now. + +NB: unconditional inlining of this sort can introduce ticks in places that +may seem surprising; for instance, the LHS of rules. See Note [Simplfying +rules] for details. -} postInlineUnconditionally @@ -1517,7 +1533,7 @@ tryEtaExpandRhs mode bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs - ; return (count isId join_bndrs, exprIsBottom join_body, rhs) } + ; return (count isId join_bndrs, exprIsDeadEnd join_body, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517) @@ -1557,7 +1573,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We now eta expand at let-bindings, which is where the payoff comes. The most significant thing is that we can do a simple arity analysis -(in GHC.Core.Arity.findRhsArity), which we can't do for free-floating lambdas +(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas One useful consequence of not eta-expanding lambdas is this example: genMap :: C a => ... @@ -1805,7 +1821,7 @@ mk_poly1 tvs_here var = do { uniq <- getUniqueM ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course + poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id mkLocalId poly_name poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1,25 +1,20 @@ {- -ToDo [Oct 2013] -~~~~~~~~~~~~~~~ -1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) -2. Nuke NoSpecConstr - (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[SpecConstr]{Specialise over constructors} -} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.Core.Opt.SpecConstr( - specConstrProgram, - SpecConstrAnnotation(..) - ) where +-- | Specialise over constructors +module GHC.Core.Opt.SpecConstr + ( specConstrProgram + ) +where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -49,7 +44,6 @@ import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Serialized ( deserializeWithData ) import GHC.Utils.Misc import GHC.Data.Pair import GHC.Types.Unique.Supply @@ -61,8 +55,6 @@ import Data.List import GHC.Builtin.Names ( specTyConName ) import GHC.Unit.Module -import GHC.Core.TyCon ( TyCon ) -import GHC.Exts( SpecConstrAnnotation(..) ) import Data.Ord( comparing ) {- @@ -454,32 +446,19 @@ specialise some (but not necessarily all!) loops regardless of their size and the number of specialisations. -We allow a library to do this, in one of two ways (one which is -deprecated): - - 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. - - 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, - and then add *that* type as a parameter to the loop body +We allow a library to force the specialisation by adding a parameter of type +GHC.Types.SPEC (from ghc-prim) to the loop body. -The reason #2 is deprecated is because it requires GHCi, which isn't -available for things like a cross compiler using stage1. + Historical note: in the past any datatype could be used in place of + GHC.Types.SPEC as long as it was annotated with GHC.Exts.ForceSpecConstr. It + has been deprecated because it required GHCi, which isn't available for + things like a cross compiler using stage1. Here's a (simplified) example from the `vector` package. You may bring the special 'force specialization' type into scope by saying: import GHC.Types (SPEC(..)) -or by defining your own type (again, deprecated): - - data SPEC = SPEC | SPEC2 - {-# ANN type SPEC ForceSpecConstr #-} - -(Note this is the exact same definition of GHC.Types.SPEC, just -without the annotation.) - -After that, you say: - foldl :: (a -> b -> a) -> a -> Stream b -> a {-# INLINE foldl #-} foldl f z (Stream step s _) = foldl_loop SPEC z s @@ -501,7 +480,7 @@ This is all quite ugly; we ought to come up with a better design. -ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set +SPEC arguments are spotted in scExpr' and scTopBinds which then set sc_force to True when calling specLoop. This flag does four things: * Ignore specConstrThreshold, to specialise functions of arbitrary size @@ -544,8 +523,8 @@ user (e.g., the accumulator here) but we still want to specialise as much as possible. -Alternatives to ForceSpecConstr -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Alternatives to SPEC +~~~~~~~~~~~~~~~~~~~~ Instead of giving the loop an extra argument of type SPEC, we also considered *wrapping* arguments in SPEC, thus data SPEC a = SPEC a | SPEC2 @@ -569,13 +548,13 @@ Note [Limit recursive specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +It is possible for SPEC to cause an infinite loop of specialisation. Because there is no limit on the number of specialisations, a recursive call with a recursive constructor as an argument (for example, list cons) will generate a specialisation for that constructor. If the resulting specialisation also contains a recursive call with the constructor, this could proceed indefinitely. -For example, if ForceSpecConstr is on: +For example, if SPEC is on: loop :: [Int] -> [Int] -> [Int] loop z [] = z loop z (x:xs) = loop (x:z) xs @@ -605,16 +584,6 @@ See #5550. Also #13623, where this test had become over-aggressive, and we lost a wonderful specialisation that we really wanted! -Note [NoSpecConstr] -~~~~~~~~~~~~~~~~~~~ -The ignoreDataCon stuff allows you to say - {-# ANN type T NoSpecConstr #-} -to mean "don't specialise on arguments of this type". It was added -before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised -regardless of size; and then we needed a way to turn that *off*. Now -that we have ForceSpecConstr, this NoSpecConstr is probably redundant. -(Used only for PArray, TODO: remove?) - ----------------------------------------------------- Stuff not yet handled ----------------------------------------------------- @@ -702,11 +671,10 @@ = do dflags <- getDynFlags us <- getUniqueSupplyM - (_, annos) <- getFirstAnnotations deserializeWithData guts this_mod <- getModule let binds' = reverse $ fst $ initUs us $ do -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod annos) + (env, binds) <- goEnv (initScEnv dflags this_mod) (mg_binds guts) -- binds is identical to (mg_binds guts), except that the -- binders on the LHS have been replaced by extendBndr @@ -821,7 +789,7 @@ -- See Note [Avoiding exponential blowup] sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops ForceSpecConstr from diverging. + -- Stops SPEC from diverging. sc_keen :: Bool, -- Specialise on arguments that are known -- constructors, even if they are not @@ -838,15 +806,13 @@ -- Binds interesting non-top-level variables -- Domain is OutVars (*after* applying the substitution) - sc_vals :: ValueEnv, + sc_vals :: ValueEnv -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) -- The range of the ValueEnv is *work-free* values -- such as (\x. blah), or (Just v) -- but NOT (Just (expensive v)) -- See Note [Work-free values only in environment] - - sc_annotations :: UniqFM SpecConstrAnnotation } --------------------- @@ -863,8 +829,8 @@ ppr LambdaVal = text "" --------------------- -initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv -initScEnv dflags this_mod anns +initScEnv :: DynFlags -> Module -> ScEnv +initScEnv dflags this_mod = SCE { sc_dflags = dflags, sc_module = this_mod, sc_size = specConstrThreshold dflags, @@ -874,8 +840,7 @@ sc_force = False, sc_subst = emptySubst, sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv, - sc_annotations = anns } + sc_vals = emptyVarEnv } data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -1000,21 +965,7 @@ --------------------------------------------------- -- See Note [Forcing specialisation] -ignoreType :: ScEnv -> Type -> Bool -ignoreDataCon :: ScEnv -> DataCon -> Bool forceSpecBndr :: ScEnv -> Var -> Bool - -ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) - -ignoreType env ty - = case tyConAppTyCon_maybe ty of - Just tycon -> ignoreTyCon env tycon - _ -> False - -ignoreTyCon :: ScEnv -> TyCon -> Bool -ignoreTyCon env tycon - = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr - forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var forceSpecFunTy :: ScEnv -> Type -> Bool @@ -1028,7 +979,6 @@ | Just (tycon, tys) <- splitTyConApp_maybe ty , tycon /= funTyCon = tyConName tycon == specTyConName - || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr || any (forceSpecArgTy env) tys forceSpecArgTy _ _ = False @@ -1601,8 +1551,8 @@ , ri_lam_body = body, ri_arg_occs = arg_occs }) spec_info@(SI { si_specs = specs, si_n_specs = spec_count , si_mb_unspec = mb_unspec }) - | isBottomingId fn -- Note [Do not specialise diverging functions] - -- and do not generate specialisation seeds from its RHS + | isDeadEndId fn -- Note [Do not specialise diverging functions] + -- and do not generate specialisation seeds from its RHS = -- pprTrace "specialise bot" (ppr fn) $ return (nullUsage, spec_info) @@ -1763,10 +1713,10 @@ -> StrictSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds topDiv + = mkClosedStrictSig spec_dmds div where spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds _) = idStrictness fn + StrictSig (DmdType _ dmds div) = idStrictness fn dmd_env = go emptyVarEnv dmds pats @@ -1826,10 +1776,10 @@ We must transfer strictness information from the original function to the specialised one. Suppose, for example - f has strictness SS + f has strictness SSx and a RULE f (a:as) b = f_spec a as b -Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need +Now we want f_spec to have strictness LLSx, otherwise we'll use call-by-need when calling f_spec instead of call-by-value. And that can result in unbounded worsening in space (cf the classic foldl vs foldl') @@ -1898,9 +1848,9 @@ of specialisations for a given function to N. * -fno-spec-constr-count sets the sc_count field to Nothing, - which switches of the limit. + which switches off the limit. -* The ghastly ForceSpecConstr trick also switches of the limit +* The ghastly SPEC trick also switches off the limit for a particular function * Otherwise we sort the patterns to choose the most general @@ -1997,7 +1947,7 @@ -- Remove ones that have too many worker variables small_pats = filterOut too_big non_dups - too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars) + too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars) -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils @@ -2151,12 +2101,12 @@ argToPat env in_scope val_env (Tick _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ - -- Note [Notes in call patterns] + -- Note [Tick annotations in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes -- Perhaps we should not ignore profiling notes, but I'm going to -- ride roughshod over them all for now. - --- See Note [Notes in RULE matching] in GHC.Core.Rules + --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules argToPat env in_scope val_env (Let _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ @@ -2173,7 +2123,6 @@ -} argToPat env in_scope val_env (Cast arg co) arg_occ - | not (ignoreType env ty2) = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ ; if not interesting then wildCardPat ty2 @@ -2204,7 +2153,6 @@ -- NB: this *precedes* the Var case, so that we catch nullary constrs argToPat env in_scope val_env arg arg_occ | Just (ConVal (DataAlt dc) args) <- isValue val_env arg - , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs @@ -2225,11 +2173,10 @@ -- In that case it counts as "interesting" argToPat env in_scope val_env (Var v) arg_occ | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value, -- (b) + is_value -- (b) -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] -- So sc_keen focused just on f (I# x), where we have freshly-allocated -- box that we can eliminate in the caller - not (ignoreType env (varType v)) = return (True, Var v) where is_value diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -33,7 +33,7 @@ import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe , mkCast, exprType ) import GHC.Core.FVs -import GHC.Core.Arity ( etaExpandToJoinPointRule ) +import GHC.Core.Opt.Arity ( etaExpandToJoinPointRule ) import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Id.Make ( voidArgId, voidPrimId ) @@ -1141,7 +1141,7 @@ is_flt_sc_arg var = isId var && not (isDeadBinder var) && isDictTy var_ty - && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) + && tyCoVarsOfType var_ty `disjointVarSet` arg_set where var_ty = idType var @@ -1362,6 +1362,7 @@ inl_prag = idInlinePragma fn inl_act = inlinePragmaActivation inl_prag is_local = isLocalId fn + is_dfun = isDFunId fn -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] @@ -1384,22 +1385,34 @@ spec_call :: SpecInfo -- Accumulating parameter -> CallInfo -- Call instance -> SpecM SpecInfo - spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) (CI { ci_key = call_args }) + spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args }) = -- See Note [Specialising Calls] - do { ( useful, rhs_env2, leftover_bndrs + do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg + | otherwise = call_args + -- See Note [Specialising DFuns] + ; ( useful, rhs_env2, leftover_bndrs , rule_bndrs, rule_lhs_args - , spec_bndrs, dx_binds, spec_args) <- specHeader env rhs_bndrs call_args + , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args +-- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci +-- , text "useful: " <+> ppr useful +-- , text "rule_bndrs:" <+> ppr rule_bndrs +-- , text "lhs_args: " <+> ppr rule_lhs_args +-- , text "spec_bndrs:" <+> ppr spec_bndrs1 +-- , text "spec_args: " <+> ppr spec_args +-- , text "dx_binds: " <+> ppr dx_binds +-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) +-- , ppr dx_binds ]) $ +-- return () + ; dflags <- getDynFlags ; if not useful -- No useful specialisation || already_covered dflags rules_acc rule_lhs_args then return spec_acc - else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids - -- , text "rhs_env2" <+> ppr (se_subst rhs_env2) - -- , ppr dx_binds ]) $ + else do { -- Run the specialiser on the specialised RHS -- The "1" suffix is before we maybe add the void arg - ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs ++ leftover_bndrs) rhs_body + ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body ; let spec_fn_ty1 = exprType spec_rhs1 -- Maybe add a void arg to the specialised function, @@ -1407,14 +1420,13 @@ -- See Note [Specialisations Must Be Lifted] -- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) - (spec_rhs, spec_fn_ty, rule_rhs_args) - | add_void_arg = ( Lam voidArgId spec_rhs1 - , mkVisFunTy voidPrimTy spec_fn_ty1 - , voidPrimId : spec_bndrs) - | otherwise = (spec_rhs1, spec_fn_ty1, spec_bndrs) + (spec_bndrs, spec_rhs, spec_fn_ty) + | add_void_arg = ( voidPrimId : spec_bndrs1 + , Lam voidArgId spec_rhs1 + , mkVisFunTy voidPrimTy spec_fn_ty1) + | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) - arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args - join_arity_decr = length rule_lhs_args - length rule_rhs_args + join_arity_decr = length rule_lhs_args - length spec_bndrs spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn = Just (orig_join_arity - join_arity_decr) | otherwise @@ -1449,7 +1461,7 @@ (idName fn) rule_bndrs rule_lhs_args - (mkVarApps (Var spec_fn) rule_rhs_args) + (mkVarApps (Var spec_fn) spec_bndrs) spec_rule = case isJoinId_maybe fn of @@ -1472,15 +1484,15 @@ = (inl_prag { inl_inline = NoUserInline }, noUnfolding) | otherwise - = (inl_prag, specUnfolding dflags fn spec_bndrs spec_app arity_decr fn_unf) - - spec_app e = e `mkApps` spec_args + = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args) + rule_lhs_args fn_unf) -------------------------------------- -- Adding arity information just propagates it a bit faster -- See Note [Arity decrease] in GHC.Core.Opt.Simplify -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_fn + arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr) `setInlinePragma` spec_inl_prag `setIdUnfolding` spec_unf @@ -1498,8 +1510,19 @@ , spec_uds `plusUDs` uds_acc ) } } -{- Note [Specialisation Must Preserve Sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Specialising DFuns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DFuns have a special sort of unfolding (DFunUnfolding), and these are +hard to specialise a DFunUnfolding to give another DFunUnfolding +unless the DFun is fully applied (#18120). So, in the case of DFunIds +we simply extend the CallKey with trailing UnspecArgs, so we'll +generate a rule that completely saturates the DFun. + +There is an ASSERT that checks this, in the DFunUnfolding case of +GHC.Core.Unfold.specUnfolding. + +Note [Specialisation Must Preserve Sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function: f :: forall a. Eq a => a -> blah @@ -2089,7 +2112,7 @@ -- -- Specialised function helpers -- , [c, i, x] -- , [dShow1 = $dfShow dShowT2] --- , [T1, T2, dEqT1, dShow1] +-- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader :: SpecEnv @@ -2106,12 +2129,13 @@ -- RULE helpers , [OutBndr] -- Binders for the RULE - , [CoreArg] -- Args for the LHS of the rule + , [OutExpr] -- Args for the LHS of the rule -- Specialised function helpers , [OutBndr] -- Binders for $sf , [DictBind] -- Auxiliary dictionary bindings , [OutExpr] -- Specialised arguments for unfolding + -- Same length as "args for LHS of rule" ) -- We want to specialise on type 'T1', and so we must construct a substitution @@ -2407,8 +2431,8 @@ callDetailsFVs :: CallDetails -> VarSet callDetailsFVs calls = - nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls - -- It's OK to use nonDetFoldUDFM here because we forget the ordering + nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls + -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering -- immediately by converting to a nondeterministic set. callInfoFVs :: CallInfoSet -> VarSet @@ -2721,7 +2745,7 @@ = extendVarSetList so_far (bindersOf bind) | otherwise = so_far - ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set) + ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set ---------------------- splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) @@ -2752,7 +2776,7 @@ deleteCallsMentioning bs calls = mapDVarEnv (ciSetFilter keep_call) calls where - keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs) + keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs deleteCallsFor :: [Id] -> CallDetails -> CallDetails -- Remove calls *for* bs diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -72,7 +72,7 @@ import Data.List (mapAccumL) import GHC.Data.FastString -#include "HsVersions.h" +#include "GhclibHsVersions.h" doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -9,7 +9,7 @@ import GHC.Prelude -import GHC.Core.Arity ( manifestArity ) +import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) import GHC.Core.Utils ( exprType, exprIsHNF ) @@ -29,7 +29,7 @@ import GHC.Core.FamInstEnv import GHC.Utils.Monad -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- We take Core bindings whose binders have: @@ -534,12 +534,12 @@ Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A binding where the manifestArity of the RHS is less than idArity of the binder -means GHC.Core.Arity didn't eta expand that binding. When this happens, it does so -for a reason (see Note [exprArity invariant] in GHC.Core.Arity) and we probably have +means GHC.Core.Opt.Arity didn't eta expand that binding. When this happens, it does so +for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression as RHS. Performing the worker/wrapper split will implicitly eta-expand the binding to -idArity, overriding GHC.Core.Arity's decision. Other than playing fast and loose with +idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with divergence, it's also broken for newtypes: f = (\xy.blah) |> co diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -14,7 +14,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -162,7 +162,7 @@ wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - ; if isWorkerSmallEnough dflags work_args + ; if isWorkerSmallEnough dflags (length demands) work_args && not (too_many_args_for_join_point wrap_args) && ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, @@ -203,10 +203,13 @@ = False -- See Note [Limit w/w arity] -isWorkerSmallEnough :: DynFlags -> [Var] -> Bool -isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags +isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool +isWorkerSmallEnough dflags old_n_args vars + = count isId vars <= max old_n_args (maxWorkerArgs dflags) -- We count only Free variables (isId) to skip Type, Kind -- variables which have no runtime representation. + -- Also if the function took 82 arguments before (old_n_args), it's fine if + -- it takes <= 82 arguments afterwards. {- Note [Always do CPR w/w] @@ -227,7 +230,8 @@ A simplified example is #11565#comment:6 Current strategy is very simple: don't perform w/w transformation at all -if the result produces a wrapper with arity higher than -fmax-worker-args=. +if the result produces a wrapper with arity higher than -fmax-worker-args +and the number arguments before w/w. It is a bit all or nothing, consider @@ -1228,7 +1232,10 @@ abs_rhs = mkAbsentErrorApp arg_ty msg msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (ppr arg <+> ppr (idType arg)) + (ppr arg <+> ppr (idType arg) <+> file_msg) + file_msg = case outputFile dflags of + Nothing -> empty + Just f -> text "in output file " <+> quotes (text f) -- We need to suppress uniques here because otherwise they'd -- end up in the generated code as strings. This is bad for -- determinism, because with different uniques the strings diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -17,7 +17,7 @@ pprFamInst ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -26,7 +26,7 @@ lookupRule, mkRule, roughTopNames ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -260,14 +260,14 @@ a good idea to treat 'M.k' as a roughTopName of the call. -} -pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc +pprRulesForUser :: [CoreRule] -> SDoc -- (a) tidy the rules -- (b) sort them into order based on the rule name -- (c) suppress uniques (unless -dppr-debug is on) -- This combination makes the output stable so we can use in testing -- It's here rather than in GHC.Core.Ppr because it calls tidyRules -pprRulesForUser dflags rules - = withPprStyle (defaultUserStyle dflags) $ +pprRulesForUser rules + = withPprStyle defaultUserStyle $ pprRules $ sortBy (comparing ruleName) $ tidyRules emptyTidyEnv rules @@ -714,11 +714,15 @@ -> CoreExpr -- Target -> Maybe RuleSubst --- We look through certain ticks. See note [Tick annotations in RULE matching] +-- We look through certain ticks. See Note [Tick annotations in RULE matching] match renv subst e1 (Tick t e2) | tickishFloatable t = match renv subst' e1 e2 where subst' = subst { rs_binds = rs_binds subst . mkTick t } +match renv subst (Tick t e1) e2 + -- Ignore ticks in rule template. + | tickishFloatable t + = match renv subst e1 e2 match _ _ e@Tick{} _ = pprPanic "Tick in rule" (ppr e) @@ -1016,7 +1020,7 @@ Note [Tick annotations in RULE matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to unconditionally look through Notes in both template and +We used to unconditionally look through ticks in both template and expression being matched. This is actually illegal for counting or cost-centre-scoped ticks, because we have no place to put them without changing entry counts and/or costs. So now we just fail the match in @@ -1025,7 +1029,12 @@ On the other hand, where we are allowed to insert new cost into the tick scope, we can float them upwards to the rule application site. -cf Note [Notes in call patterns] in GHC.Core.Opt.SpecConstr +Moreover, we may encounter ticks in the template of a rule. There are a few +ways in which these may be introduced (e.g. #18162, #17619). Such ticks are +ignored by the matcher. See Note [Simplifying rules] in +GHC.Core.Opt.Simplify.Utils for details. + +cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr Note [Matching lets] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -13,7 +13,7 @@ tidyExpr, tidyRules, tidyUnfolding ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -10,7 +10,7 @@ -- | GHC.CoreToByteCode: Generate bytecode from Core module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -13,14 +13,14 @@ module GHC.CoreToStg ( coreToStg ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, findDefault, isJoinBind , exprIsTickedString_maybe ) -import GHC.Core.Arity ( manifestArity ) +import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Stg.Syntax import GHC.Core.Type @@ -45,7 +45,7 @@ import GHC.Driver.Ways import GHC.Types.ForeignCall import GHC.Types.Demand ( isUsedOnce ) -import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) +import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Builtin.Names ( unsafeEqualityProofName ) @@ -539,12 +539,10 @@ (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) -- Some primitive operator that might be implemented as a library call. - -- As described in Note [Primop wrappers] in GHC.Builtin.PrimOps, here we - -- turn unsaturated primop applications into applications of - -- the primop's wrapper. - PrimOpId op - | saturated -> StgOpApp (StgPrimOp op) args' res_ty - | otherwise -> StgApp (primOpWrapperId op) args' + -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps + -- we require that primop applications be saturated. + PrimOpId op -> ASSERT( saturated ) + StgOpApp (StgPrimOp op) args' res_ty -- A call to some primitive Cmm function. FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -15,7 +15,7 @@ lookupMkNaturalName, lookupNaturalSDataConName ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform @@ -26,7 +26,7 @@ import GHC.Builtin.Names import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Core.Utils -import GHC.Core.Arity +import GHC.Core.Opt.Arity import GHC.Core.FVs import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) @@ -71,7 +71,7 @@ The goal of this pass is to prepare for code generation. -1. Saturate constructor applications. +1. Saturate constructor and primop applications. 2. Convert to A-normal form; that is, function arguments are always variables. @@ -760,7 +760,13 @@ | CpeCast Coercion | CpeTick (Tickish Id) -{- Note [runRW arg] +instance Outputable ArgInfo where + ppr (CpeApp arg) = text "app" <+> ppr arg + ppr (CpeCast co) = text "cast" <+> ppr co + ppr (CpeTick tick) = text "tick" <+> ppr tick + +{- + Note [runRW arg] ~~~~~~~~~~~~~~~~~~~ If we got, say runRW# (case bot of {}) @@ -823,14 +829,23 @@ -- rather than the far superior "f x y". Test case is par01. = let (terminal, args', depth') = collect_args arg in cpe_app env terminal (args' ++ args) (depth + depth' - 1) - cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1 + cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n | f `hasKey` runRWKey + -- N.B. While it may appear that n == 1 in the case of runRW# + -- applications, keep in mind that we may have applications that return + , n >= 1 -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of - Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0 - _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1 + Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2) + _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1) + -- TODO: What about casts? + + cpe_app _env (Var f) args n + | f `hasKey` runRWKey + = pprPanic "cpe_app(runRW#)" (ppr args $$ ppr n) + cpe_app env (Var v) args depth = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -959,9 +974,78 @@ => (State# RealWorld -> (# State# RealWorld, o #)) -> (# State# RealWorld, o #) -It needs no special treatment in GHC except this special inlining here -in CorePrep (and in GHC.CoreToByteCode). +It's correctness needs no special treatment in GHC except this special inlining +here in CorePrep (and in GHC.CoreToByteCode). +However, there are a variety of optimisation opportunities that the simplifier +takes advantage of. See Note [Simplification of runRW#]. + + +Note [Simplification of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the program, + + case runRW# (\s -> let n = I# 42# in n) of + I# n# -> f n# + +There is no reason why we should allocate an I# constructor given that we +immediately destructure it. To avoid this the simplifier will push strict +contexts into runRW's continuation. That is, it transforms + + K[ runRW# @r @ty cont ] + ~> + runRW# @r @ty K[cont] + +This has a few interesting implications. Consider, for instance, this program: + + join j = ... + in case runRW# @r @ty cont of + result -> jump j result + +Performing the transform described above would result in: + + join j x = ... + in runRW# @r @ty (\s -> + case cont of in + result -> jump j result + ) + +If runRW# were a "normal" function this call to join point j would not be +allowed in its continuation argument. However, since runRW# is inlined (as +described in Note [runRW magic] above), such join point occurences are +completely fine. Both occurrence analysis and Core Lint have special treatment +for runRW# applications. See Note [Linting of runRW#] for details on the latter. + +Moreover, it's helpful to ensure that runRW's continuation isn't floated out +(since doing so would then require a call, whereas we would otherwise end up +with straight-line). Consequently, GHC.Core.Opt.SetLevels.lvlApp has special +treatment for runRW# applications, ensure the arguments are not floated if +MFEs. + +Other considered designs +------------------------ + +One design that was rejected was to *require* that runRW#'s continuation be +headed by a lambda. However, this proved to be quite fragile. For instance, +SetLevels is very eager to float bottoming expressions. For instance given +something of the form, + + runRW# @r @ty (\s -> case expr of x -> undefined) + +SetLevels will see that the body the lambda is bottoming and will consequently +float it to the top-level (assuming expr has no free coercion variables which +prevent this). We therefore end up with + + runRW# @r @ty (\s -> lvl s) + +Which the simplifier will beta reduce, leaving us with + + runRW# @r @ty lvl + +Breaking our desired invariant. Ultimately we decided to simply accept that +the continuation may not be a manifest lambda. + + -- --------------------------------------------------------------------------- -- CpeArg: produces a result satisfying CpeArg -- --------------------------------------------------------------------------- @@ -1067,15 +1151,11 @@ unsaturated applications (identified by 'hasNoBinding', currently just foreign calls and unboxed tuple/sum constructors). -Note that eta expansion in CorePrep is very fragile due to the "prediction" of -CAFfyness made during tidying (see Note [CAFfyness inconsistencies due to eta -expansion in CorePrep] in GHC.Iface.Tidy for details. We previously saturated primop +Historical Note: Note that eta expansion in CorePrep used to be very fragile +due to the "prediction" of CAFfyness that we used to make during tidying. +We previously saturated primop applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. - -It's quite likely that eta expansion of constructor applications will -eventually break in a similar way to how primops did. We really should -eliminate this case as well. -} maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs @@ -1136,7 +1216,7 @@ and now we do NOT want eta expansion to give f = /\a -> \ y -> (let s = h 3 in g s) y -Instead GHC.Core.Arity.etaExpand gives +Instead GHC.Core.Opt.Arity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y -} diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs --- a/compiler/GHC/Data/Graph/Ops.hs +++ b/compiler/GHC/Data/Graph/Ops.hs @@ -79,8 +79,8 @@ = let -- add back conflict edges from other nodes to this one map_conflict = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the + nonDetStrictFoldUniqSet + -- It's OK to use a non-deterministic fold here because the -- operation is commutative (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) @@ -89,8 +89,8 @@ -- add back coalesce edges from other nodes to this one map_coalesce = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the + nonDetStrictFoldUniqSet + -- It's OK to use a non-deterministic fold here because the -- operation is commutative (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) @@ -492,9 +492,9 @@ else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set" -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - -- It's OK to use nonDetFoldUFM here because the operation - -- is commutative + fm2 = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative $ nodeCoalesce node in fm2 diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -16,7 +16,7 @@ module GHC.Driver.Backpack (doBackpack) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -515,9 +515,9 @@ -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not -- to qualify packages so we can use simple names for them. -backpackStyle :: DynFlags -> PprStyle -backpackStyle dflags = - mkUserStyle dflags +backpackStyle :: PprStyle +backpackStyle = + mkUserStyle (QueryQualify neverQualifyNames alwaysQualifyModules neverQualifyPackages) AllTheWay @@ -537,7 +537,7 @@ level <- getBkpLevel liftIO . backpackProgressMsg level dflags $ "Instantiating " ++ renderWithStyle - (initSDocContext dflags (backpackStyle dflags)) + (initSDocContext dflags backpackStyle) (ppr pk) -- | Message when we include a Backpack unit. @@ -547,7 +547,7 @@ level <- getBkpLevel liftIO . backpackProgressMsg level dflags $ showModuleIndex (i, n) ++ "Including " ++ - renderWithStyle (initSDocContext dflags (backpackStyle dflags)) + renderWithStyle (initSDocContext dflags backpackStyle) (ppr uid) -- ---------------------------------------------------------------------------- diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -13,7 +13,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -86,8 +86,7 @@ NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) - err + $ withPprStyle defaultDumpStyle err ; ghcExit dflags 1 } Nothing -> return () diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -32,7 +32,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -774,7 +774,7 @@ provenance (ModOrigin{ fromOrigPackage = e, fromHiddenReexport = rhs }) | Just False <- e - = parens (text "needs flag -package-key" + = parens (text "needs flag -package-id" <+> ppr (moduleUnit mod)) | (pkg:_) <- rhs = parens (text "needs flag -package-id" diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -178,10 +178,10 @@ import GHC.Iface.Ext.Ast ( mkHieFile ) import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) -import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..)) import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ********************************************************************** @@ -438,8 +438,7 @@ putMsg dflags $ text "Got invalid scopes" mapM_ (putMsg dflags) xs -- Roundtrip testing - nc <- readIORef $ hsc_NC hs_env - (file', _) <- readHieFile nc out_file + file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file case diffFile hieFile (hie_file_result file') of [] -> putMsg dflags $ text "Got no roundtrip errors" @@ -1161,7 +1160,7 @@ where inferredImportWarn = unitBag $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) - $ mkErrMsg dflags l (pkgQual dflags) + $ mkWarnMsg dflags l (pkgQual dflags) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) @@ -1385,7 +1384,7 @@ -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. @@ -1542,7 +1541,7 @@ -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (Stream IO CmmGroupSRTs NameSet) + -> IO (Stream IO CmmGroupSRTs NonCaffySet) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -31,7 +31,7 @@ moduleGraphNodes, SummaryNode ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -53,7 +53,7 @@ import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) import GHC.Types.Basic import GHC.Data.Graph.Directed -import GHC.Utils.Exception ( tryIO, gbracket, gfinally ) +import GHC.Utils.Exception ( tryIO ) import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) import GHC.Types.Name @@ -85,6 +85,7 @@ import Control.Exception import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) +import qualified Control.Monad.Catch as MC import Data.IORef import Data.List import qualified Data.List as List @@ -907,7 +908,7 @@ -- | Each module is given a unique 'LogQueue' to redirect compilation messages -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)]) +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)]) !(MVar ()) -- | The graph of modules to compile and their corresponding result 'MVar' and @@ -994,10 +995,10 @@ -- Reset the number of capabilities once the upsweep ends. let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n - gbracket updNumCapabilities resetNumCapabilities $ \_ -> do + MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do -- Sync the global session with the latest HscEnv once the upsweep ends. - let finallySyncSession io = io `gfinally` do + let finallySyncSession io = io `MC.finally` do hsc_env <- liftIO $ readMVar hsc_env_var setSession hsc_env @@ -1061,7 +1062,7 @@ -- Unmask asynchronous exceptions and perform the thread-local -- work to compile the module (see parUpsweep_one). - m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ + m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem hsc_env_var old_hpt_var @@ -1097,12 +1098,12 @@ -- Kill all the workers, masking interrupts (since killThread is -- interruptible). XXX: This is not ideal. - ; killWorkers = uninterruptibleMask_ . mapM_ killThread } + ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread } -- Spawn the workers, making sure to kill them later. Collect the results -- of each compile. - results <- liftIO $ bracket spawnWorkers killWorkers $ \_ -> + results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ -> -- Loop over each module in the compilation graph in order, printing -- each message from its log_queue. forM comp_graph $ \(mod,mvar,log_queue) -> do @@ -1126,7 +1127,7 @@ return (success_flag,ok_results) where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO () writeLogQueue (LogQueue ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -1135,8 +1136,8 @@ -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do - writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg)) + parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do + writeLogQueue log_queue (Just (reason,severity,srcSpan,msg)) -- Print each message from the log_queue using the log_action from the -- session's DynFlags. @@ -1149,8 +1150,8 @@ print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (reason,severity,srcSpan,style,msg) -> do - putLogMsg dflags reason severity srcSpan style msg + Just (reason,severity,srcSpan,msg) -> do + putLogMsg dflags reason severity srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -1278,7 +1279,7 @@ let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) -- Limit the number of parallel compiles. - let withSem sem = bracket_ (waitQSem sem) (signalQSem sem) + let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) mb_mod_info <- withSem par_sem $ handleSourceError (\err -> do logger err; return Nothing) $ do -- Have the ModSummary and HscEnv point to our local log_action @@ -2653,8 +2654,8 @@ errors <- liftIO $ newIORef [] fatals <- liftIO $ newIORef [] - let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do - let action = putLogMsg dflags reason severity srcSpan style msg + let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do + let action = putLogMsg dflags reason severity srcSpan msg case severity of SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) @@ -2671,7 +2672,7 @@ setLogAction action = modifySession $ \hsc_env -> hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } - gbracket + MC.bracket (setLogAction deferDiagnostics) (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) (\_ -> f) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -13,7 +13,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -34,7 +35,7 @@ ) where #include -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -77,6 +78,7 @@ import System.FilePath import System.IO import Control.Monad +import qualified Control.Monad.Catch as MC (handle) import Data.List ( isInfixOf, intercalate ) import Data.Maybe import Data.Version @@ -101,7 +103,7 @@ -> IO (Either ErrorMessages (DynFlags, FilePath)) preprocess hsc_env input_fn mb_input_buf mb_phase = handleSourceError (\err -> return (Left (srcErrorMessages err))) $ - ghandle handler $ + MC.handle handler $ fmap Right $ do MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) @@ -1913,7 +1915,7 @@ = do when (haveRtsOptsFlags dflags) $ do putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) + $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -16,7 +16,7 @@ deSugar, deSugarExpr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -14,7 +14,7 @@ module GHC.HsToCore.Arrows ( dsProcExpr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -23,7 +23,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -33,7 +33,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils -import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) +import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches ) import GHC.Hs -- lots of things import GHC.Core -- lots of things @@ -41,7 +41,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Make import GHC.Core.Utils -import GHC.Core.Arity ( etaExpand ) +import GHC.Core.Opt.Arity ( etaExpand ) import GHC.Core.Unfold import GHC.Core.FVs import GHC.Data.Graph.Directed @@ -145,12 +145,20 @@ else [] ; return (force_var, [core_bind]) } -dsHsBind dflags b@(FunBind { fun_id = L _ fun +dsHsBind dflags b@(FunBind { fun_id = L loc fun , fun_matches = matches , fun_ext = co_fn , fun_tick = tick }) - = do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName fun)) + = do { (args, body) <- addTyCsDs FromSource (hsWrapDictBinders co_fn) $ + -- FromSource might not be accurate (we don't have any + -- origin annotations for things in this module), but at + -- worst we do superfluous calls to the pattern match + -- oracle. + -- addTyCsDs: Add type evidence to the refinement type + -- predicate of the coverage checker + -- See Note [Type and Term Equality Propagation] in PmCheck + matchWrapper + (mkPrefixFunRhs (L loc (idName fun))) Nothing matches ; core_wrap <- dsHsWrapper co_fn ; let body' = mkOptTickBox tick body @@ -189,15 +197,7 @@ , abs_exports = exports , abs_ev_binds = ev_binds , abs_binds = binds, abs_sig = has_sig }) - = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource) - -- FromSource might not be accurate, but at worst - -- we do superfluous calls to the pattern match - -- oracle. - -- addTyCsDs: push type constraints deeper - -- for inner pattern match check - -- See Check, Note [Type and Term Equality Propagation] - (addTyCsDs (listToBag dicts)) - (dsLHsBinds binds) + = do { ds_binds <- addTyCsDs FromSource (listToBag dicts) (dsLHsBinds binds) ; ds_ev_binds <- dsTcEvBinds_s ev_binds @@ -206,7 +206,6 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" - ----------------------- dsAbsBinds :: DynFlags -> [TyVar] -> [EvVar] -> [ABExport GhcTc] @@ -694,20 +693,19 @@ dflags <- getDynFlags ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (rule_bndrs, _fn, args) -> do + Right (rule_bndrs, _fn, rule_lhs_args) -> do { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding dflags poly_id spec_bndrs core_app arity_decrease fn_unf + spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - arity_decrease = count isValArg args - count isId spec_bndrs ; rule <- dsMkUserRule this_mod is_local_id (mkFastString ("SPEC " ++ showPpr dflags poly_name)) rule_act poly_name - rule_bndrs args + rule_bndrs rule_lhs_args (mkVarApps (Var spec_id) spec_bndrs) ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -78,8 +78,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds | let dflags = hsc_dflags hsc_env passes = coveragePasses dflags, not (null passes), - Just orig_file <- ml_hs_file mod_loc, - not ("boot" `isSuffixOf` orig_file) = do + Just orig_file <- ml_hs_file mod_loc = do let orig_file2 = guessSourceFile binds orig_file @@ -118,7 +117,7 @@ dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) - return (binds1, HpcInfo tickCount hashNo, Just modBreaks) + return (binds1, HpcInfo tickCount hashNo, modBreaks) | otherwise = return (binds, emptyHpcInfo False, Nothing) @@ -135,23 +134,23 @@ _ -> orig_file -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks +mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks) mkModBreaks hsc_env mod count entries - | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do + | breakpointsEnabled (hsc_dflags hsc_env) = do breakArray <- GHCi.newBreakArray hsc_env (length entries) ccs <- mkCCSArray hsc_env mod count entries let locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - return emptyModBreaks + return $ Just $ emptyModBreaks { modBreaks_flags = breakArray , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks , modBreaks_decls = declsTicks , modBreaks_ccs = ccs } - | otherwise = return emptyModBreaks + | otherwise = return Nothing mkCCSArray :: HscEnv -> Module -> Int -> [MixEntry_] @@ -1004,11 +1003,20 @@ (addTickLHsExpr e2) (addTickLHsExpr e3) -data TickTransState = TT { tickBoxCount:: Int +data TickTransState = TT { tickBoxCount:: !Int , mixEntries :: [MixEntry_] - , ccIndices :: CostCentreState + , ccIndices :: !CostCentreState } +addMixEntry :: MixEntry_ -> TM Int +addMixEntry ent = do + c <- tickBoxCount <$> getState + setState $ \st -> + st { tickBoxCount = c + 1 + , mixEntries = ent : mixEntries st + } + return c + data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity , tte_dflags :: DynFlags @@ -1028,7 +1036,7 @@ coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = - ifa (hscTarget dflags == HscInterpreted) Breakpoints $ + ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (gopt Opt_SccProfilingOn dflags && profAuto dflags /= NoProfAuto) ProfNotes $ @@ -1036,6 +1044,10 @@ where ifa f x xs | f = x:xs | otherwise = xs +-- | Should we produce 'Breakpoint' ticks? +breakpointsEnabled :: DynFlags -> Bool +breakpointsEnabled dflags = hscTarget dflags == HscInterpreted + -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to -- LINE pragmas in the code - which would confuse at least HPC. @@ -1202,11 +1214,7 @@ dflags <- getDynFlags env <- getEnv case tickishType env of - HpcTicks -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me : mixEntries st } - return $ HpcTick (this_mod env) c + HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me ProfNotes -> do let nm = mkFastString cc_name @@ -1215,11 +1223,7 @@ count = countEntries && gopt Opt_ProfCountEntries dflags return $ ProfNote cc count True{-scopes-} - Breakpoints -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me:mixEntries st } - return $ Breakpoint c ids + Breakpoints -> Breakpoint <$> addMixEntry me <*> pure ids SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' cc_name @@ -1240,22 +1244,15 @@ mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -mkBinTickBoxHpc boxLabel pos e = - TM $ \ env st -> - let meT = (pos,declPath env, [],boxLabel True) - meF = (pos,declPath env, [],boxLabel False) - meE = (pos,declPath env, [],ExpBox False) - c = tickBoxCount st - mes = mixEntries st - in - ( L pos $ HsTick noExtField (HpcTick (this_mod env) c) - $ L pos $ HsBinTick noExtField (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) +mkBinTickBoxHpc boxLabel pos e = do + env <- getEnv + binTick <- HsBinTick noExtField + <$> addMixEntry (pos,declPath env, [],boxLabel True) + <*> addMixEntry (pos,declPath env, [],boxLabel False) + <*> pure e + tick <- HpcTick (this_mod env) + <$> addMixEntry (pos,declPath env, [],ExpBox False) + return $ L pos $ HsTick noExtField tick (L pos binTick) mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s _) diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -14,7 +14,7 @@ import GHC.Hs.Doc import GHC.Hs.Decls import GHC.Hs.Extension -import GHC.Hs.Types +import GHC.Hs.Type import GHC.Hs.Utils import GHC.Types.Name import GHC.Types.Name.Set diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -20,7 +20,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -32,7 +32,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad -import GHC.HsToCore.PmCheck ( checkGuardMatches ) +import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) @@ -280,7 +280,8 @@ HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc) XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap) - _ -> dsExpr e + _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $ + dsExpr e -- See Note [Detecting forced eta expansion] ; wrap' <- dsHsWrapper co_fn ; dflags <- getDynFlags @@ -337,26 +338,47 @@ That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO. -Operator sections. At first it looks as if we can convert -\begin{verbatim} - (expr op) -\end{verbatim} -to -\begin{verbatim} - \x -> op expr x -\end{verbatim} +Note [Desugaring operator sections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At first it looks as if we can convert + + (expr `op`) + +naively to + + \x -> op expr x + But no! expr might be a redex, and we can lose laziness badly this way. Consider -\begin{verbatim} - map (expr op) xs -\end{verbatim} -for example. So we convert instead to -\begin{verbatim} - let y = expr in \x -> op y x -\end{verbatim} -If \tr{expr} is actually just a variable, say, then the simplifier -will sort it out. + + map (expr `op`) xs + +for example. If expr were a redex then eta-expanding naively would +result in multiple evaluations where the user might only have expected one. + +So we convert instead to + + let y = expr in \x -> op y x + +Also, note that we must do this for both right and (perhaps surprisingly) left +sections. Why are left sections necessary? Consider the program (found in #18151), + + seq (True `undefined`) () + +according to the Haskell Report this should reduce to () (as it specifies +desugaring via eta expansion). However, if we fail to eta expand we will rather +bottom. Consequently, we must eta expand even in the case of a left section. + +If `expr` is actually just a variable, say, then the simplifier +will inline `y`, eliminating the redundant `let`. + +Note that this works even in the case that `expr` is unlifted. In this case +bindNonRec will automatically do the right thing, giving us: + + case expr of y -> (\x -> op y x) + +See #18151. -} dsExpr e@(OpApp _ e1 op e2) @@ -365,17 +387,35 @@ ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } -dsExpr (SectionL _ expr op) -- Desugar (e !) to ((!) e) - = do { op' <- dsLExpr op - ; dsWhenNoErrs (dsLExprNoLP expr) - (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } +-- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y +-- +-- See Note [Desugaring operator sections]. +-- N.B. this also must handle postfix operator sections due to -XPostfixOperators. +dsExpr e@(SectionL _ expr op) = do + core_op <- dsLExpr op + x_core <- dsLExpr expr + case splitFunTys (exprType core_op) of + -- Binary operator section + (x_ty:y_ty:_, _) -> do + dsWhenNoErrs + (mapM newSysLocalDsNoLP [x_ty, y_ty]) + (\[x_id, y_id] -> + bindNonRec x_id x_core + $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e) + core_op [Var x_id, Var y_id])) --- dsLExpr (SectionR op expr) -- \ x -> op x expr + -- Postfix operator section + (_:_, _) -> do + return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core + + _ -> pprPanic "dsExpr(SectionL)" (ppr e) + +-- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr +-- +-- See Note [Desugaring operator sections]. dsExpr e@(SectionR _ op expr) = do core_op <- dsLExpr op - -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) - -- See comment with SectionL y_core <- dsLExpr expr dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> bindNonRec y_id y_core $ diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -19,7 +19,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -127,7 +127,7 @@ arg_tys = map exprType val_args body_ty = (mkVisFunTys arg_tys res_ty) tyvars = tyCoVarsOfTypeWellScoped body_ty - ty = mkInvForAllTys tyvars body_ty + ty = mkInfForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -15,7 +15,7 @@ module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Tc.Utils.Monad -- temp diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -11,7 +11,7 @@ module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -12,7 +12,7 @@ module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -21,7 +21,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform @@ -859,8 +859,10 @@ do { dflags <- getDynFlags ; locn <- getSrcSpanDs - -- Pattern match check warnings - ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) + -- Pattern match check warnings + ; if isMatchContextPmChecked dflags FromSource ctx + then checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) + else pure () ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] , eqn_orig = FromSource diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -14,7 +14,7 @@ module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -21,7 +21,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -14,13 +14,13 @@ module GHC.HsToCore.PmCheck ( -- Checking and printing checkSingle, checkMatches, checkGuardMatches, - needToRunPmCheck, isMatchContextPmChecked, + isMatchContextPmChecked, -- See Note [Type and Term Equality Propagation] addTyCsDs, addScrutTmCs ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -45,7 +45,7 @@ import GHC.Core.TyCon import GHC.Types.Var (EvVar) import GHC.Core.Coercion -import GHC.Tc.Types.Evidence ( HsWrapper(..), isIdHsWrapper ) +import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) import GHC.Tc.Utils.TcType (evVarPred) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) @@ -53,6 +53,7 @@ import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Data.Bag +import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Core.TyCo.Rep import GHC.Core.Type @@ -1033,20 +1034,30 @@ these constraints. -} +-- | Locally update 'dsl_deltas' with the given action, but defer evaluation +-- with 'unsafeInterleaveM' in order not to do unnecessary work. locallyExtendPmDelta :: (Deltas -> DsM Deltas) -> DsM a -> DsM a -locallyExtendPmDelta ext k = getPmDeltas >>= ext >>= \deltas -> do - inh <- isInhabited deltas - -- If adding a constraint would lead to a contradiction, don't add it. - -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@ - -- for why this is done. - if inh - then updPmDeltas deltas k - else k +locallyExtendPmDelta ext k = do + deltas <- getPmDeltas + deltas' <- unsafeInterleaveM $ do + deltas' <- ext deltas + inh <- isInhabited deltas' + -- If adding a constraint would lead to a contradiction, don't add it. + -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@ + -- for why this is done. + if inh + then pure deltas' + else pure deltas + updPmDeltas deltas' k --- | Add in-scope type constraints -addTyCsDs :: Bag EvVar -> DsM a -> DsM a -addTyCsDs ev_vars = - locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars)) +-- | Add in-scope type constraints if the coverage checker might run and then +-- run the given action. +addTyCsDs :: Origin -> Bag EvVar -> DsM a -> DsM a +addTyCsDs origin ev_vars m = do + dflags <- getDynFlags + applyWhen (needToRunPmCheck dflags origin) + (locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars))) + m -- | Add equalities for the scrutinee to the local 'DsM' environment when -- checking a case expression: diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -23,7 +23,7 @@ provideEvidence ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -89,6 +89,7 @@ printer <- mkPrintUnqualifiedDs liftIO $ dumpIfSet_dyn_printer printer dflags Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) +{-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id @@ -438,7 +439,7 @@ newtypes. (b) dcs is the list of newtype constructors "skipped", every time we normalise a newtype to its core representation, we keep track of the source data - constructor. For convenienve, we also track the type we unwrap and the + constructor. For convenience, we also track the type we unwrap and the type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)] (c) core_ty is the rewritten type. That is, pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty) @@ -1275,7 +1276,7 @@ we do the following: 1. We normalise the outermost type family redex, data family redex or newtype, - using pmTopNormaliseType (in types/FamInstEnv.hs). This computes 3 + using pmTopNormaliseType (in "GHC.Core.FamInstEnv"). This computes 3 things: (a) A normalised type src_ty, which is equal to the type of the scrutinee in source Haskell (does not normalise newtypes or data families) @@ -1290,7 +1291,7 @@ newtype rewrite performed in (b). For an example see also Note [Type normalisation] - in types/FamInstEnv.hs. + in "GHC.Core.FamInstEnv". 2. Function Check.checkEmptyCase' performs the check: - If core_ty is not an algebraic type, then we cannot check for diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs --- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs +++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs @@ -8,7 +8,7 @@ pprUncovered ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -4,6 +4,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -24,7 +29,7 @@ module GHC.HsToCore.Quote( dsBracket ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform @@ -106,7 +111,7 @@ -- Only used for the defensive assertion that the selector has -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) - expected_ty = mkForAllTys tyvars $ + expected_ty = mkInvisForAllTys tyvars $ mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars))) (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) @@ -464,7 +469,7 @@ tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds })) = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> + ; dec <- addQTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt -- See Note [Scoped type variables in class and instance declarations] ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds @@ -494,9 +499,9 @@ ------------------------- repDataDefn :: Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) + -> Either (Core [(M (TH.TyVarBndr ()))]) -- the repTyClD case - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -- the repDataFamInstD case -> HsDataDefn GhcRn -> MetaM (Core (M TH.Dec)) @@ -520,7 +525,7 @@ derivs1 } } -repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)] +repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> LHsType GhcRn -> MetaM (Core (M TH.Dec)) repSynDecl tc bndrs ty @@ -534,7 +539,7 @@ , fdResultSig = L _ resultSig , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn + ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = [] , hsq_explicit = tvs } resTyVar = case resultSig of @@ -681,7 +686,7 @@ ; let hs_tvs = HsQTvs { hsq_ext = var_names , hsq_explicit = fromMaybe [] mb_bndrs } ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName + do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName repTyVarBndr mb_bndrs ; tys1 <- case fixity of @@ -718,7 +723,7 @@ ; let hs_tvs = HsQTvs { hsq_ext = var_names , hsq_explicit = fromMaybe [] mb_bndrs } ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName + do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName repTyVarBndr mb_bndrs ; tys1 <- case fixity of @@ -803,7 +808,7 @@ do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs ; ss <- mkGenSyms tm_bndr_names ; rule <- addBinds ss $ - do { elt_ty <- wrapName tyVarBndrTyConName + do { elt_ty <- wrapName tyVarBndrUnitTyConName ; ty_bndrs' <- return $ case ty_bndrs of Nothing -> coreNothing' (mkListTy elt_ty) Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs @@ -821,7 +826,7 @@ ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] ruleBndrNames (L _ (RuleBndrSig _ n sig)) - | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig + | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig = unLoc n : vars repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) @@ -830,7 +835,7 @@ ; rep2 ruleVarName [n'] } repRuleBndr (L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n - ; MkC ty' <- repLTy (hsSigWcType sig) + ; MkC ty' <- repLTy (hsPatSigType sig) ; rep2 typedRuleVarName [n', ty'] } repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -875,22 +880,23 @@ } } -repC (L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs +repC (L _ (ConDeclGADT { con_g_ext = imp_tvs + , con_names = cons + , con_qvars = exp_tvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty })) - | isEmptyLHsQTvs qtvs -- No implicit or explicit variables - , Nothing <- mcxt -- No context - -- ==> no need for a forall + | null imp_tvs && null exp_tvs -- No implicit or explicit variables + , Nothing <- mcxt -- No context + -- ==> no need for a forall = repGadtDataCons cons args res_ty | otherwise - = addTyVarBinds qtvs $ \ ex_bndrs -> + = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs -> -- See Note [Don't quantify implicit type variables in quotes] do { c' <- repGadtDataCons cons args res_ty ; ctxt' <- repMbContext mcxt - ; if null (hsQTvExplicit qtvs) && isNothing mcxt + ; if null exp_tvs && isNothing mcxt then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } @@ -995,7 +1001,7 @@ = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv + ; th_explicit_tvs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv explicit_tvs -- NB: Don't pass any implicit type variables to repList above @@ -1023,8 +1029,8 @@ = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs - ; th_exis <- repListM tyVarBndrTyConName rep_in_scope_tv exis + ; th_univs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv univs + ; th_exis <- repListM tyVarBndrSpecTyConName rep_in_scope_tv exis -- NB: Don't pass any implicit type variables to repList above -- See Note [Don't quantify implicit type variables in quotes] @@ -1110,44 +1116,74 @@ -- Types ------------------------------------------------------- -addSimpleTyVarBinds :: [Name] -- the binders to be added - -> MetaM (Core (M a)) -- action in the ext env +class RepTV flag flag' | flag -> flag' where + tyVarBndrName :: Name + repPlainTV :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag'))) + repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind) + -> MetaM (Core (M (TH.TyVarBndr flag'))) + +instance RepTV () () where + tyVarBndrName = tyVarBndrUnitTyConName + repPlainTV (MkC nm) () = rep2 plainTVName [nm] + repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki] + +instance RepTV Specificity TH.Specificity where + tyVarBndrName = tyVarBndrSpecTyConName + repPlainTV (MkC nm) spec = do { (MkC spec') <- rep_flag spec + ; rep2 plainInvisTVName [nm, spec'] } + repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec + ; rep2 kindedInvisTVName [nm, spec', ki] } + +rep_flag :: Specificity -> MetaM (Core TH.Specificity) +rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] +rep_flag InferredSpec = rep2_nw inferredSpecName [] + +addSimpleTyVarBinds :: [Name] -- the binders to be added + -> MetaM (Core (M a)) -- action in the ext env -> MetaM (Core (M a)) addSimpleTyVarBinds names thing_inside = do { fresh_names <- mkGenSyms names ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } -addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env +addHsTyVarBinds :: forall flag flag' a. RepTV flag flag' + => [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) addHsTyVarBinds exp_tvs thing_inside = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) ; term <- addBinds fresh_exp_names $ - do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr + do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr (exp_tvs `zip` fresh_exp_names) ; thing_inside kbs } ; wrapGenSyms fresh_exp_names term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env +addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added + -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs + , hsq_explicit = exp_tvs }) + thing_inside + = addTyVarBinds exp_tvs imp_tvs thing_inside + +addTyVarBinds :: RepTV flag flag' + => [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> [Name] + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_ext = imp_tvs - , hsq_explicit = exp_tvs }) - thing_inside +addTyVarBinds exp_tvs imp_tvs thing_inside = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ thing_inside addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) + -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -> MetaM (Core (M a)) - -- Used for data/newtype declarations, and family instances, -- so that the nested type variables work right -- instance C (T a) where @@ -1161,34 +1197,36 @@ -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr + do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } where - mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) + mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ()))) mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- -repTyVarBndrWithKind :: LHsTyVarBndr GhcRn - -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) -repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm - = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm - = repLTy ki >>= repKindedTV nm +repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn + -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm + = repPlainTV nm fl +repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm + = do { ki' <- repLTy ki + ; repKindedTV nm fl ki' } -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) -repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) +repTyVarBndr :: RepTV flag flag' + => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndr (L _ (UserTyVar _ fl (L _ nm)) ) = do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) + ; repPlainTV nm' fl } +repTyVarBndr (L _ (KindedTyVar _ fl (L _ nm) ki)) = do { nm' <- lookupBinder nm ; ki' <- repLTy ki - ; repKindedTV nm' ki' } + ; repKindedTV nm' fl ki' } -- represent a type context -- @@ -1243,7 +1281,9 @@ repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = case fvf of ForallInvis -> repForallT ty - ForallVis -> addHsTyVarBinds tvs $ \bndrs -> + ForallVis -> let tvs' = map ((<$>) (setHsTyVarBndrFlag ())) tvs + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type + in addHsTyVarBinds tvs' $ \bndrs -> do body1 <- repLTy body repTForallVis bndrs body1 repTy ty@(HsQualTy {}) = repForallT ty @@ -1935,7 +1975,7 @@ repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP (SigPat _ p t) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) + ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice repP other = notHandled "Exotic pattern" (ppr other) @@ -2332,8 +2372,8 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] repData :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -> Either (Core [(M (TH.TyVarBndr ()))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) @@ -2343,8 +2383,8 @@ = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] repNewtype :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -> Either (Core [(M (TH.TyVarBndr ()))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) @@ -2354,7 +2394,7 @@ (MkC derivs) = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] -repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)] +repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2409,7 +2449,7 @@ just = coreJust overlapTyConName -repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)] +repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> Core [TH.FunDep] -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -2442,7 +2482,7 @@ repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec)) repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] -repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)]) +repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))]) -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp) -> Core TH.Phases -> MetaM (Core (M TH.Dec)) repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) @@ -2455,13 +2495,13 @@ repTySynInst (MkC eqn) = rep2 tySynInstDName [eqn] -repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)] +repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) = rep2 dataFamilyDName [nm, tvs, kind] repOpenFamilyD :: Core TH.Name - -> Core [(M TH.TyVarBndr)] + -> Core [(M (TH.TyVarBndr ()))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> MetaM (Core (M TH.Dec)) @@ -2469,7 +2509,7 @@ = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [(M TH.TyVarBndr)] + -> Core [(M (TH.TyVarBndr ()))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> Core [(M TH.TySynEqn)] @@ -2477,7 +2517,7 @@ repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] -repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) -> +repTySynEqn :: Core (Maybe [(M (TH.TyVarBndr ()))]) -> Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn)) repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) = rep2 tySynEqnName [mb_bndrs, lhs, rhs] @@ -2560,12 +2600,12 @@ ------------ Types ------------------- -repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type) +repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] -repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type) +repTForallVis :: Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] @@ -2654,14 +2694,6 @@ repPromotedConsTyCon :: MetaM (Core (M TH.Type)) repPromotedConsTyCon = rep2 promotedConsTName [] ------------- TyVarBndrs ------------------- - -repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) -repPlainTV (MkC nm) = rep2 plainTVName [nm] - -repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr)) -repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] - ---------------------------------------------------------- -- Type family result signature @@ -2671,7 +2703,7 @@ repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig)) repKindSig (MkC ki) = rep2 kindSigName [ki] -repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig)) +repTyVarSig :: Core (M (TH.TyVarBndr ())) -> MetaM (Core (M TH.FamilyResultSig)) repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -9,7 +9,7 @@ mkUsageInfo, mkUsedNames, mkDependencies ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -261,9 +261,9 @@ -- ent_map groups together all the things imported and used -- from a particular module ent_map :: ModuleEnv [OccName] - ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names - -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName - -- in ent_hashs + ent_map = nonDetStrictFoldUniqSet add_mv emptyModuleEnv used_names + -- nonDetStrictFoldUniqSet is OK here. If you follow the logic, we sort by + -- OccName in ent_hashs where add_mv name mv_map | isWiredInName name = mv_map -- ignore wired-in names diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -44,7 +44,7 @@ isTrueLHsExpr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -482,7 +482,6 @@ Var v1 | isInternalName (idName v1) -> v1 -- Note [Desugaring seq], points (2) and (3) _ -> mkWildValBinder ty1 - mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make -- NB: No argument can be levity polymorphic @@ -568,10 +567,10 @@ * The pattern binds exactly one variable let !(Just (Just x) = e in body ==> - let { t = case e of Just (Just v) -> Unit v - ; v = case t of Unit v -> v } + let { t = case e of Just (Just v) -> Solo v + ; v = case t of Solo v -> v } in t `seq` body - The 'Unit' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types + The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types Note that forcing 't' makes the pattern match happen, but does not force 'v'. @@ -585,8 +584,8 @@ ------ Examples ---------- * !(_, (_, a)) = e ==> - t = case e of (_, (_, a)) -> Unit a - a = case t of Unit a -> a + t = case e of (_, (_, a)) -> Solo a + a = case t of Solo a -> a Note that - Forcing 't' will force the pattern to match fully; @@ -596,8 +595,8 @@ * !(Just x) = e ==> - t = case e of Just x -> Unit x - x = case t of Unit x -> x + t = case e of Just x -> Solo x + x = case t of Solo x -> x Again, forcing 't' will fail if 'e' yields Nothing. @@ -608,12 +607,12 @@ let Just (Just v) = e in body ==> - let t = case e of Just (Just v) -> Unit v - v = case t of Unit v -> v + let t = case e of Just (Just v) -> Solo v + v = case t of Solo v -> v in body ==> - let v = case (case e of Just (Just v) -> Unit v) of - Unit v -> v + let v = case (case e of Just (Just v) -> Solo v) of + Solo v -> v in body ==> let v = case e of Just (Just v) -> v diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -31,7 +31,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -92,15 +92,16 @@ -> NameCacheUpdater -> IO ModIface readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do - let printer :: SDoc -> IO () + let platform = targetPlatform dflags + + printer :: SDoc -> IO () printer = case traceBinIFaceReading of TraceBinIFaceReading -> \sd -> putLogMsg dflags NoReason SevOutput noSrcSpan - (defaultDumpStyle dflags) - sd + $ withPprStyle defaultDumpStyle sd QuietBinIFaceReading -> \_ -> return () wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () @@ -122,20 +123,9 @@ -- (This magic number does not change when we change -- GHC interface file format) magic <- get bh - wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr + wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength) errorOnMismatch "magic number mismatch: old/corrupt interface file?" - (binaryInterfaceMagic dflags) magic - - -- Note [dummy iface field] - -- read a dummy 32/64 bit value. This field used to hold the - -- dictionary pointer in old interface file formats, but now - -- the dictionary pointer is after the version (where it - -- should be). Also, the serialisation of value of type "Bin - -- a" used to depend on the word size of the machine, now they - -- are always 32 bits. - case platformWordSize (targetPlatform dflags) of - PW4 -> do _ <- Binary.get bh :: IO Word32; return () - PW8 -> do _ <- Binary.get bh :: IO Word64; return () + (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) -- Check the interface file version and ways. check_ver <- get bh @@ -194,14 +184,8 @@ writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () writeBinIface dflags hi_path mod_iface = do bh <- openBinMem initBinMemSize - put_ bh (binaryInterfaceMagic dflags) - - -- dummy 32/64-bit field before the version/way for - -- compatibility with older interface file formats. - -- See Note [dummy iface field] above. - case platformWordSize (targetPlatform dflags) of - PW4 -> Binary.put_ bh (0 :: Word32) - PW8 -> Binary.put_ bh (0 :: Word64) + let platform = targetPlatform dflags + put_ bh (binaryInterfaceMagic platform) -- The version and way descriptor go next put_ bh (show hiVersion) @@ -288,10 +272,10 @@ initBinMemSize :: Int initBinMemSize = 1024 * 1024 -binaryInterfaceMagic :: DynFlags -> Word32 -binaryInterfaceMagic dflags - | target32Bit (targetPlatform dflags) = 0x1face - | otherwise = 0x1face64 +binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32 +binaryInterfaceMagic platform + | target32Bit platform = FixedLengthEncoding 0x1face + | otherwise = FixedLengthEncoding 0x1face64 -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -20,7 +20,7 @@ mkNameCacheUpdater, NameCacheUpdater(..), ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -2,9 +2,12 @@ Main functions for .hie file generation -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,36 +16,47 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where +import GHC.Utils.Outputable(ppr) + import GHC.Prelude import GHC.Types.Avail ( Avails ) import GHC.Data.Bag ( Bag, bagToList ) import GHC.Types.Basic import GHC.Data.BooleanFormula -import GHC.Core.Class ( FunDep ) +import GHC.Core.Class ( FunDep, className, classSCSelIds ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike ( conLikeName ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) +import GHC.Core.FVs import GHC.HsToCore ( deSugarExpr ) import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types import GHC.Unit.Module ( ModuleName, ml_hs_file ) import GHC.Utils.Monad ( concatMapM, liftIO ) -import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc ) +import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) import GHC.Core.Type ( mkVisFunTys, Type ) +import GHC.Core.Predicate +import GHC.Core.InstEnv import GHC.Builtin.Types ( mkListTy, mkSumTy ) -import GHC.Types.Var ( Id, Var, setVarName, varName, varType ) import GHC.Tc.Types +import GHC.Tc.Types.Evidence +import GHC.Types.Var ( Id, Var, EvId, setVarName, varName, varType, varUnique ) +import GHC.Types.Var.Env +import GHC.Types.Unique import GHC.Iface.Make ( mkIfaceExports ) import GHC.Utils.Panic import GHC.Data.Maybe +import GHC.Data.FastString import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils @@ -53,6 +67,8 @@ import qualified Data.Set as S import Data.Data ( Data, Typeable ) import Data.List ( foldl1' ) +import Control.Monad ( forM_ ) +import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class ( lift ) @@ -184,7 +200,7 @@ -} --- These synonyms match those defined in main/GHC.hs +-- These synonyms match those defined in compiler/GHC.hs type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)] , Maybe LHsDocString ) @@ -196,12 +212,47 @@ We don't care about the distinction between mono and poly bindings, so we replace all occurrences of the mono name with the poly name. -} -newtype HieState = HieState +type VarMap a = DVarEnv (Var,a) +data HieState = HieState { name_remapping :: NameEnv Id + , unlocated_ev_binds :: VarMap (S.Set ContextInfo) + -- These contain evidence bindings that we don't have a location for + -- These are placed at the top level Node in the HieAST after everything + -- else has been generated + -- This includes things like top level evidence bindings. } +addUnlocatedEvBind :: Var -> ContextInfo -> HieM () +addUnlocatedEvBind var ci = do + let go (a,b) (_,c) = (a,S.union b c) + lift $ modify' $ \s -> + s { unlocated_ev_binds = + extendDVarEnv_C go (unlocated_ev_binds s) + var (var,S.singleton ci) + } + +getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) +getUnlocatedEvBinds file = do + binds <- lift $ gets unlocated_ev_binds + org <- ask + let elts = dVarEnvElts binds + + mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) + + go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of + RealSrcSpan spn _ + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) + _ -> (mkNodeInfo e : xs,ys) + + (nis,asts) = foldr go ([],[]) elts + + pure $ (M.fromList nis, asts) + initState :: HieState -initState = HieState emptyNameEnv +initState = HieState emptyNameEnv emptyDVarEnv class ModifyState a where -- See Note [Name Remapping] addSubstitution :: a -> a -> HieState -> HieState @@ -216,10 +267,11 @@ modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState modifyState = foldr go id where - go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f + go ABE{abe_poly=poly,abe_mono=mono} f + = addSubstitution mono poly . f go _ f = f -type HieM = ReaderT HieState Hsc +type HieM = ReaderT NodeOrigin (StateT HieState Hsc) -- | Construct an 'HieFile' from the outputs of the typechecker. mkHieFile :: ModSummary @@ -239,7 +291,10 @@ -> RenamedSource -> Hsc HieFile mkHieFileWithSource src_file src ms ts rs = do let tc_binds = tcg_binds ts - (asts', arr) <- getCompressedAsts tc_binds rs + top_ev_binds = tcg_ev_binds ts + insts = tcg_insts ts + tcs = tcg_tcs ts + (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs return $ HieFile { hie_hs_file = src_file , hie_module = ms_mod ms @@ -250,38 +305,70 @@ , hie_hs_src = src } -getCompressedAsts :: TypecheckedSource -> RenamedSource +getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) -getCompressedAsts ts rs = do - asts <- enrichHie ts rs +getCompressedAsts ts rs top_ev_binds insts tcs = do + asts <- enrichHie ts rs top_ev_binds insts tcs return $ compressTypes asts -enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) -enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do +enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = + flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts rasts <- processGrp hsGrp imps <- toHie $ filter (not . ideclImplicit . unLoc) imports exps <- toHie $ fmap (map $ IEC Export . fst) exports - let spanFile children = case children of - [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) + -- Add Instance bindings + forM_ insts $ \i -> + addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) + -- Add class parent bindings + forM_ tcs $ \tc -> + case tyConClass_maybe tc of + Nothing -> pure () + Just c -> forM_ (classSCSelIds c) $ \v -> + addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) + let spanFile file children = case children of + [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) (realSrcSpanEnd $ nodeSpan $ last children) - modulify xs = - Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs - - asts = HieASTs - $ resolveTyVarScopes - $ M.map (modulify . mergeSortAsts) - $ M.fromListWith (++) - $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts - flat_asts = concat [ tasts , rasts , imps , exps ] + + modulify file xs' = do + + top_ev_asts <- + toHie $ EvBindContext ModuleScope Nothing + $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) + $ EvBinds ev_bs + + (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file + + let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts + span = spanFile file xs + + moduleInfo = SourcedNodeInfo + $ M.singleton SourceInfo + $ (simpleNodeInfo "Module" "Module") + {nodeIdentifiers = uloc_evs} + + moduleNode = Node moduleInfo span [] + + case mergeSortAsts $ moduleNode : xs of + [x] -> return x + xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs) + + asts' <- sequence + $ M.mapWithKey modulify + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + let asts = HieASTs $ resolveTyVarScopes asts' return asts where processGrp grp = concatM @@ -305,13 +392,16 @@ grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) grhss_span (XGRHSs _) = panic "XGRHS has no span" -bindingsOnly :: [Context Name] -> [HieAST a] -bindingsOnly [] = [] -bindingsOnly (C c n : xs) = case nameSrcSpan n of - RealSrcSpan span _ -> Node nodeinfo span [] : bindingsOnly xs - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) - info = mempty{identInfo = S.singleton c} - _ -> bindingsOnly xs +bindingsOnly :: [Context Name] -> HieM [HieAST a] +bindingsOnly [] = pure [] +bindingsOnly (C c n : xs) = do + org <- ask + rest <- bindingsOnly xs + pure $ case nameSrcSpan n of + RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> rest concatM :: Monad m => [m [a]] -> m [a] concatM xs = concat <$> sequence xs @@ -345,6 +435,8 @@ data SigType = BindSig | ClassSig | InstSig +data EvBindContext a = EvBindContext Scope (Maybe Span) a + data RScoped a = RS Scope a -- ^ Scope spans over everything to the right of a, (mostly) not -- including a itself @@ -394,8 +486,8 @@ tvScopes :: TyVarScope -> Scope - -> [LHsTyVarBndr a] - -> [TVScoped (LHsTyVarBndr a)] + -> [LHsTyVarBndr flag a] + -> [TVScoped (LHsTyVarBndr flag a)] tvScopes tvScope rhsScope xs = map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs @@ -413,35 +505,9 @@ -- ^ a is in scope here (pattern body) bax (x :: a) = ... -- a is in scope here -Because of HsWC and HsIB pass on their scope to their children -we must wrap the LHsType in pattern signatures in a -Shielded explicitly, so that the HsWC/HsIB scope is not passed -on the the LHsType --} -data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead - -type family ProtectedSig a where - ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs - GhcRn - (Shielded (LHsType GhcRn))) - ProtectedSig GhcTc = NoExtField - -class ProtectSig a where - protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a - -instance (HasLoc a) => HasLoc (Shielded a) where - loc (SH _ a) = loc a - -instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where - toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) - -instance ProtectSig GhcTc where - protectSig _ _ = noExtField - -instance ProtectSig GhcRn where - protectSig sc (HsWC a (HsIB b sig)) = - HsWC a (HsIB b (SH sc sig)) +This case in handled in the instance for HsPatSigType +-} class HasLoc a where -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can @@ -509,7 +575,7 @@ toHie :: a -> HieM [HieAST Type] -- | Used to collect type info -class Data a => HasType a where +class HasType a where getTypeNode :: a -> HieM [HieAST Type] instance (ToHie a) => ToHie [a] where @@ -521,15 +587,10 @@ instance (ToHie a) => ToHie (Maybe a) where toHie = maybe (pure []) toHie -instance ToHie (Context (Located NoExtField)) where - toHie _ = pure [] - -instance ToHie (TScoped NoExtField) where - toHie _ = pure [] - instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span _) mname)) = - pure $ [Node (NodeInfo S.empty [] idents) span []] + toHie (IEC c (L (RealSrcSpan span _) mname)) = do + org <- ask + pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] where details = mempty{identInfo = S.singleton (IEThing c)} idents = M.singleton (Left mname) details toHie _ = pure [] @@ -537,64 +598,100 @@ instance ToHie (Context (Located Var)) where toHie c = case c of C context (L (RealSrcSpan span _) name') - -> do - m <- asks name_remapping - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - pure - [Node - (NodeInfo S.empty [] $ - M.singleton (Right $ varName name) - (IdentifierDetails (Just $ varType name') - (S.singleton context))) - span - []] + | varUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just $ varType name') + (S.singleton context))) + span + []] + C (EvidenceVarBind i _ sp) (L _ name) -> do + addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) + pure [] _ -> pure [] instance ToHie (Context (Located Name)) where toHie c = case c of - C context (L (RealSrcSpan span _) name') -> do - m <- asks name_remapping - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' - pure - [Node - (NodeInfo S.empty [] $ - M.singleton (Right name) - (IdentifierDetails Nothing - (S.singleton context))) - span - []] + C context (L (RealSrcSpan span _) name') + | nameUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] _ -> pure [] --- | Dummy instances - never called -instance ToHie (TScoped (LHsSigWcType GhcTc)) where - toHie _ = pure [] -instance ToHie (TScoped (LHsWcType GhcTc)) where - toHie _ = pure [] -instance ToHie (SigContext (LSig GhcTc)) where - toHie _ = pure [] -instance ToHie (TScoped Type) where - toHie _ = pure [] - -instance HasType (LHsBind GhcRn) where - getTypeNode (L spn bind) = makeNode bind spn +evVarsOfTermList :: EvTerm -> [EvId] +evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e +evVarsOfTermList (EvTypeable _ ev) = + case ev of + EvTypeableTyCon _ e -> concatMap evVarsOfTermList e + EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] + EvTypeableTrFun e1 e2 -> concatMap evVarsOfTermList [e1,e2] + EvTypeableTyLit e -> evVarsOfTermList e +evVarsOfTermList (EvFun{}) = [] -instance HasType (LHsBind GhcTc) where - getTypeNode (L spn bind) = case bind of - FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) - _ -> makeNode bind spn +instance ToHie (EvBindContext (Located TcEvBinds)) where + toHie (EvBindContext sc sp (L span (EvBinds bs))) + = concatMapM go $ bagToList bs + where + go evbind = do + let evDeps = evVarsOfTermList $ eb_rhs evbind + depNames = EvBindDeps $ map varName evDeps + concatM $ + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) + (L span $ eb_lhs evbind)) + , toHie $ map (C EvidenceVarUse . L span) $ evDeps + ] + toHie _ = pure [] -instance HasType (Located (Pat GhcRn)) where - getTypeNode (L spn pat) = makeNode pat spn +instance ToHie (Located HsWrapper) where + toHie (L osp wrap) + = case wrap of + (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) + (WpCompose a b) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpFun a b _ _) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpEvLam a) -> + toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) + $ L osp a + (WpEvApp a) -> + concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a + _ -> pure [] -instance HasType (Located (Pat GhcTc)) where - getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat) +instance HiePass p => HasType (LHsBind (GhcPass p)) where + getTypeNode (L spn bind) = + case hiePass @p of + HieRn -> makeNode bind spn + HieTc -> case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn +instance HiePass p => HasType (Located (Pat (GhcPass p))) where + getTypeNode (L spn pat) = + case hiePass @p of + HieRn -> makeNode pat spn + HieTc -> makeTypeNode pat spn (hsPatType pat) -- | This instance tries to construct 'HieAST' nodes which include the type of -- the expression. It is not yet possible to do this efficiently for all @@ -611,70 +708,100 @@ -- expression's type is going to be expensive. -- -- See #16233 -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = lift $ - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) +instance HiePass p => HasType (LHsExpr (GhcPass p)) where + getTypeNode e@(L spn e') = + case hiePass @p of + HieRn -> makeNode e' spn + HieTc -> + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - ExplicitList ty _ _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty - _ -> Nothing + _ -> Nothing - in - case tyOpt of - Just t -> makeTypeNode e' spn t - Nothing - | skipDesugaring e' -> fallback - | otherwise -> do - hs_env <- Hsc $ \e w -> return (e,w) - (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe - where - fallback = makeNode e' spn + in + case tyOpt of + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkVisFunTys args res + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkVisFunTys args res - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr GhcTc -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - XExpr (HsWrap{}) -> False - _ -> True + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr GhcTc -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + XExpr (HsWrap{}) -> False + _ -> True -instance ( ToHie (Context (Located (IdP a))) - , ToHie (MatchGroup a (LHsExpr a)) - , ToHie (PScoped (LPat a)) - , ToHie (GRHSs a (LHsExpr a)) - , ToHie (LHsExpr a) - , ToHie (Located (PatSynBind a a)) - , HasType (LHsBind a) - , ModifyState (IdP a) - , Data (HsBind a) - ) => ToHie (BindContext (LHsBind a)) where +data HiePassEv p where + HieRn :: HiePassEv 'Renamed + HieTc :: HiePassEv 'Typechecked + +class ( IsPass p + , HiePass (NoGhcTcPass p) + , ModifyState (IdGhcP p) + , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) + , Data (HsExpr (GhcPass p)) + , Data (HsCmd (GhcPass p)) + , Data (AmbiguousFieldOcc (GhcPass p)) + , Data (HsCmdTop (GhcPass p)) + , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) + , Data (HsSplice (GhcPass p)) + , Data (HsLocalBinds (GhcPass p)) + , Data (FieldOcc (GhcPass p)) + , Data (HsTupArg (GhcPass p)) + , Data (IPBind (GhcPass p)) + , ToHie (Context (Located (IdGhcP p))) + , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) + , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) + , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) + , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) + , HasRealDataConName (GhcPass p) + ) + => HiePass p where + hiePass :: HiePassEv p + +instance HiePass 'Renamed where + hiePass = HieRn +instance HiePass 'Typechecked where + hiePass = HieTc + +instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where toHie (BC context scope b@(L span bind)) = concatM $ getTypeNode b : case bind of - FunBind{fun_id = name, fun_matches = matches} -> + FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> [ toHie $ C (ValBind context scope $ getRealSpan span) name , toHie matches + , case hiePass @p of + HieTc -> toHie $ L span wrap + _ -> pure [] ] PatBind{pat_lhs = lhs, pat_rhs = rhs} -> [ toHie $ PS (getRealSpan span) scope NoScope lhs @@ -683,39 +810,52 @@ VarBind{var_rhs = expr} -> [ toHie expr ] - AbsBinds{abs_exports = xs, abs_binds = binds} -> - [ local (modifyState xs) $ -- Note [Name Remapping] - toHie $ fmap (BC context scope) binds + AbsBinds{ abs_exports = xs, abs_binds = binds + , abs_ev_binds = ev_binds + , abs_ev_vars = ev_vars } -> + [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] + (toHie $ fmap (BC context scope) binds) + , toHie $ map (L span . abe_wrap) xs + , toHie $ + map (EvBindContext (mkScope span) (getRealSpan span) + . L span) ev_binds + , toHie $ + map (C (EvidenceVarBind EvSigBind + (mkScope span) + (getRealSpan span)) + . L span) ev_vars ] PatSynBind _ psb -> [ toHie $ L span psb -- PatSynBinds only occur at the top level ] - XHsBindsLR _ -> [] -instance ( ToHie (LMatch a body) - ) => ToHie (MatchGroup a body) where - toHie mg = concatM $ case mg of - MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> - [ pure $ locOnly span - , toHie alts - ] - MG{} -> [] - XMatchGroup _ -> [] +instance ( HiePass p + , ToHie (Located body) + , Data body + ) => ToHie (MatchGroup (GhcPass p) (Located body)) where + toHie mg = case mg of + MG{ mg_alts = (L span alts) , mg_origin = origin} -> + local (setOrigin origin) $ concatM + [ locOnly span + , toHie alts + ] -instance ( ToHie (Context (Located (IdP a))) - , ToHie (PScoped (LPat a)) - , ToHie (HsPatSynDir a) - ) => ToHie (Located (PatSynBind a a)) where +setOrigin :: Origin -> NodeOrigin -> NodeOrigin +setOrigin FromSource _ = SourceInfo +setOrigin Generated _ = GeneratedInfo + +instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where toHie (L sp psb) = concatM $ case psb of PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var , toHie $ toBind dets - , toHie $ PS Nothing lhsScope NoScope pat + , toHie $ PS Nothing lhsScope patScope pat , toHie dir ] where lhsScope = combineScopes varScope detScope varScope = mkLScope var + patScope = mkScope $ getLoc pat detScope = case dets of (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) @@ -728,54 +868,40 @@ toBind (PrefixCon args) = PrefixCon $ map (C Use) args toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) toBind (RecCon r) = RecCon $ map (PSC detSpan) r - XPatSynBind _ -> [] -instance ( ToHie (MatchGroup a (LHsExpr a)) - ) => ToHie (HsPatSynDir a) where +instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where toHie dir = case dir of ExplicitBidirectional mg -> toHie mg _ -> pure [] -instance ( a ~ GhcPass p - , ToHie body - , ToHie (HsMatchContext (NoGhcTc a)) - , ToHie (PScoped (LPat a)) - , ToHie (GRHSs a body) - , Data (Match a body) - ) => ToHie (LMatch (GhcPass p) body) where - toHie (L span m ) = concatM $ makeNode m span : case m of +instance ( HiePass p + , Data body + , ToHie (Located body) + ) => ToHie (LMatch (GhcPass p) (Located body)) where + toHie (L span m ) = concatM $ node : case m of Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> [ toHie mctx , let rhsScope = mkScope $ grhss_span grhss in toHie $ patScopes Nothing rhsScope NoScope pats , toHie grhss ] + where + node = case hiePass @p of + HieTc -> makeNode m span + HieRn -> makeNode m span -instance ( ToHie (Context (Located (IdP a))) - ) => ToHie (HsMatchContext a) where +instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name toHie (StmtCtxt a) = toHie a toHie _ = pure [] -instance ( ToHie (HsMatchContext a) - ) => ToHie (HsStmtContext a) where +instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where toHie (PatGuard a) = toHie a toHie (ParStmtCtxt a) = toHie a toHie (TransStmtCtxt a) = toHie a toHie _ = pure [] -instance ( a ~ GhcPass p - , IsPass p - , ToHie (Context (Located (IdP a))) - , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) - , ToHie (LHsExpr a) - , ToHie (TScoped (LHsSigWcType a)) - , ProtectSig a - , ToHie (TScoped (ProtectedSig a)) - , HasType (LPat a) - , Data (HsSplice a) - , IsPass p - ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where +instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where toHie (PS rsp scope pscope lpat@(L ospan opat)) = concatM $ getTypeNode lpat : case opat of WildPat _ -> @@ -808,13 +934,25 @@ SumPat _ pat _ _ -> [ toHie $ PS rsp scope pscope pat ] - ConPat {pat_con = con, pat_args = dets}-> - [ case ghcPass @p of - GhcPs -> toHie $ C Use $ con - GhcRn -> toHie $ C Use $ con - GhcTc -> toHie $ C Use $ fmap conLikeName con - , toHie $ contextify dets - ] + ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> + case hiePass @p of + HieTc -> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + , let ev_binds = cpt_binds ext + ev_vars = cpt_dicts ext + wrap = cpt_wrap ext + evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope + in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds + , toHie $ L ospan wrap + , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) + . L ospan) ev_vars + ] + ] + HieRn -> + [ toHie $ C Use con + , toHie $ contextify dets + ] ViewPat _ expr pat -> [ toHie expr , toHie $ PS rsp scope pscope pat @@ -831,21 +969,26 @@ ] SigPat _ pat sig -> [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope pat in - toHie $ TS (ResolvedScopes [cscope, scope, pscope]) - (protectSig @a cscope sig) - -- See Note [Scoping Rules for SigPat] + , case hiePass @p of + HieTc -> + let cscope = mkLScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + sig + HieRn -> pure [] ] - XPat e -> case ghcPass @p of + XPat e -> + case hiePass @p of + HieTc -> + let CoPat wrap pat _ = e + in [ toHie $ L ospan wrap + , toHie $ PS rsp scope pscope $ (L ospan pat) + ] #if __GLASGOW_HASKELL__ < 811 - GhcPs -> noExtCon e - GhcRn -> noExtCon e + HieRn -> [] #endif - GhcTc -> [] - where - -- Make sure we get an error if this changes - _noWarn@(CoPat _ _ _) = e where + contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) + -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args contextify (InfixCon a b) = InfixCon a' b' where [a', b'] = patScopes rsp scope pscope [a,b] @@ -856,49 +999,39 @@ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun scoped_fds = listScopes pscope fds -instance ( ToHie body - , ToHie (LGRHS a body) - , ToHie (RScoped (LHsLocalBinds a)) - ) => ToHie (GRHSs a body) where + +instance ToHie (TScoped (HsPatSigType GhcRn)) where + toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) + , toHie body + ] + -- See Note [Scoping Rules for SigPat] + +instance ( ToHie (Located body) + , HiePass p + , Data body + ) => ToHie (GRHSs (GhcPass p) (Located body)) where toHie grhs = concatM $ case grhs of GRHSs _ grhss binds -> [ toHie grhss , toHie $ RS (mkScope $ grhss_span grhs) binds ] - XGRHSs _ -> [] instance ( ToHie (Located body) - , ToHie (RScoped (GuardLStmt a)) - , Data (GRHS a (Located body)) - ) => ToHie (LGRHS a (Located body)) where - toHie (L span g) = concatM $ makeNode g span : case g of + , HiePass a + , Data body + ) => ToHie (LGRHS (GhcPass a) (Located body)) where + toHie (L span g) = concatM $ node : case g of GRHS _ guards body -> [ toHie $ listScopes (mkLScope body) guards , toHie body ] - XGRHS _ -> [] + where + node = case hiePass @a of + HieRn -> makeNode g span + HieTc -> makeNode g span -instance ( a ~ GhcPass p - , ToHie (Context (Located (IdP a))) - , HasType (LHsExpr a) - , ToHie (PScoped (LPat a)) - , ToHie (MatchGroup a (LHsExpr a)) - , ToHie (LGRHS a (LHsExpr a)) - , ToHie (RContext (HsRecordBinds a)) - , ToHie (RFContext (Located (AmbiguousFieldOcc a))) - , ToHie (ArithSeqInfo a) - , ToHie (LHsCmdTop a) - , ToHie (RScoped (GuardLStmt a)) - , ToHie (RScoped (LHsLocalBinds a)) - , ToHie (TScoped (LHsWcType (NoGhcTc a))) - , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) - , Data (HsExpr a) - , Data (HsSplice a) - , Data (HsTupArg a) - , Data (AmbiguousFieldOcc a) - , (HasRealDataConName a) - , IsPass p - ) => ToHie (LHsExpr (GhcPass p)) where +instance HiePass p => ToHie (LHsExpr (GhcPass p)) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) -> [ toHie $ C Use (L mspan var) @@ -972,14 +1105,14 @@ , toHie expr ] HsDo _ _ (L ispan stmts) -> - [ pure $ locOnly ispan + [ locOnly ispan , toHie $ listScopes NoScope stmts ] ExplicitList _ _ exprs -> [ toHie exprs ] RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @a mrealcon name) + [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) -- See Note [Real DataCon Name] , toHie $ RC RecFieldAssign $ binds ] @@ -1026,33 +1159,24 @@ ] XExpr x | GhcTc <- ghcPass @p - , HsWrap _ a <- x - -> [ toHie $ L mspan a ] - - | otherwise - -> [] + , HsWrap w a <- x + -> [ toHie $ L mspan a + , toHie (L mspan w) + ] + | otherwise -> [] -instance ( a ~ GhcPass p - , ToHie (LHsExpr a) - , Data (HsTupArg a) - ) => ToHie (LHsTupArg (GhcPass p)) where +instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where toHie (L span arg) = concatM $ makeNode arg span : case arg of Present _ expr -> [ toHie expr ] Missing _ -> [] -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (LHsExpr a) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (LHsLocalBinds a)) - , ToHie (RScoped (ApplicativeArg a)) - , ToHie (Located body) - , Data (StmtLR a a (Located body)) - , Data (StmtLR a a (Located (HsExpr a))) +instance ( ToHie (Located body) + , Data body + , HiePass p ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where - toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of + toHie (RS scope (L span stmt)) = concatM $ node : case stmt of LastStmt _ body _ _ -> [ toHie body ] @@ -1082,27 +1206,36 @@ RecStmt {recS_stmts = stmts} -> [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts ] + where + node = case hiePass @p of + HieTc -> makeNode stmt span + HieRn -> makeNode stmt span -instance ( ToHie (LHsExpr a) - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (HsLocalBinds a) - ) => ToHie (RScoped (LHsLocalBinds a)) where +instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of EmptyLocalBinds _ -> [] - HsIPBinds _ _ -> [] + HsIPBinds _ ipbinds -> case ipbinds of + IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in + [ case hiePass @p of + HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds + HieRn -> pure [] + , toHie $ map (RS sc) xs + ] HsValBinds _ valBinds -> [ toHie $ RS (combineScopes scope $ mkScope sp) valBinds ] - XHsLocalBindsLR _ -> [] -instance ( ToHie (BindContext (LHsBind a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (XXValBindsLR a a)) - ) => ToHie (RScoped (HsValBindsLR a a)) where +instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where + toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of + IPBind _ (Left _) expr -> [toHie expr] + IPBind _ (Right v) expr -> + [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) + $ L sp v + , toHie expr + ] + +instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where toHie (RS sc v) = concatM $ case v of ValBinds _ binds sigs -> [ toHie $ fmap (BC RegularBind sc) binds @@ -1110,26 +1243,19 @@ ] XValBindsLR x -> [ toHie $ RS sc x ] -instance ToHie (RScoped (NHsValBindsLR GhcTc)) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] -instance ToHie (RScoped (NHsValBindsLR GhcRn)) where +instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where toHie (RS sc (NValBinds binds sigs)) = concatM $ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) , toHie $ fmap (SC (SI BindSig Nothing)) sigs ] -instance ( ToHie (RContext (LHsRecField a arg)) - ) => ToHie (RContext (HsRecFields a arg)) where +instance ( ToHie arg , HasLoc arg , Data arg + , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields instance ( ToHie (RFContext (Located label)) - , ToHie arg - , HasLoc arg + , ToHie arg , HasLoc arg , Data arg , Data label - , Data arg ) => ToHie (RContext (LHsRecField' label arg)) where toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of HsRecField label expr _ -> @@ -1172,15 +1298,7 @@ in [ toHie $ C (RecField c rhs) (L nspan var') ] -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (LHsExpr a) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (StmtLR a a (Located (HsExpr a))) - , Data (HsLocalBinds a) - ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where +instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM [ toHie $ PS Nothing sc NoScope pat , toHie expr @@ -1195,28 +1313,13 @@ toHie (RecCon rec) = toHie rec toHie (InfixCon a b) = concatM [ toHie a, toHie b] -instance ( ToHie (LHsCmd a) - , Data (HsCmdTop a) - ) => ToHie (LHsCmdTop a) where +instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where toHie (L span top) = concatM $ makeNode top span : case top of HsCmdTop _ cmd -> [ toHie cmd ] - XCmdTop _ -> [] -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (LHsExpr a) - , ToHie (MatchGroup a (LHsCmd a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (HsCmd a) - , Data (HsCmdTop a) - , Data (StmtLR a a (Located (HsCmd a))) - , Data (HsLocalBinds a) - , Data (StmtLR a a (Located (HsExpr a))) - ) => ToHie (LHsCmd (GhcPass p)) where +instance HiePass p => ToHie (LHsCmd (GhcPass p)) where toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of HsCmdArrApp _ a b _ _ -> [ toHie a @@ -1253,7 +1356,7 @@ , toHie cmd' ] HsCmdDo _ (L ispan stmts) -> - [ pure $ locOnly ispan + [ locOnly ispan , toHie $ listScopes NoScope stmts ] XCmd _ -> [] @@ -1307,7 +1410,7 @@ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs , toHie $ fmap (BC InstanceBind ModuleScope) meths , toHie typs - , concatMapM (pure . locOnly . getLoc) deftyps + , concatMapM (locOnly . getLoc) deftyps , toHie deftyps ] where @@ -1331,7 +1434,7 @@ instance ToHie (FamilyInfo GhcRn) where toHie (ClosedTypeFamily (Just eqns)) = concatM $ - [ concatMapM (pure . locOnly . getLoc) eqns + [ concatMapM (locOnly . getLoc) eqns , toHie $ map go eqns ] where @@ -1389,7 +1492,7 @@ instance ToHie (HsDeriving GhcRn) where toHie (L span clauses) = concatM - [ pure $ locOnly span + [ locOnly span , toHie clauses ] @@ -1397,7 +1500,7 @@ toHie (L span cl) = concatM $ makeNode cl span : case cl of HsDerivingClause _ strat (L ispan tys) -> [ toHie strat - , pure $ locOnly ispan + , locOnly ispan , toHie $ map (TS (ResolvedScopes [])) tys ] @@ -1409,14 +1512,15 @@ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] instance ToHie (Located OverlapMode) where - toHie (L span _) = pure $ locOnly span + toHie (L span _) = locOnly span instance ToHie (LConDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of - ConDeclGADT { con_names = names, con_qvars = qvars + ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names - , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars + , concatM $ [ bindingsOnly bindings + , toHie $ tvScopes resScope NoScope exp_vars ] , toHie ctx , toHie args , toHie typ @@ -1426,6 +1530,8 @@ ctxScope = maybe NoScope mkLScope ctx argsScope = condecl_scope args tyScope = mkLScope typ + resScope = ResolvedScopes [ctxScope, rhsScope] + bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets } -> [ toHie $ C (Decl ConDec $ getRealSpan span) name @@ -1444,7 +1550,7 @@ instance ToHie (Located [LConDeclField GhcRn]) where toHie (L span decls) = concatM $ - [ pure $ locOnly span + [ locOnly span , toHie decls ] @@ -1452,7 +1558,7 @@ , ToHie (TScoped thing) ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where toHie (TS sc (HsIB ibrn a)) = concatM $ - [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn , toHie $ TS sc a ] where span = loc a @@ -1461,7 +1567,7 @@ , ToHie (TScoped thing) ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where toHie (TS sc (HsWC names a)) = concatM $ - [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names , toHie $ TS sc a ] where span = loc a @@ -1476,48 +1582,51 @@ , toHie $ TS (ResolvedScopes []) typ ] -instance ToHie (SigContext (LSig GhcRn)) where - toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of - TypeSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - PatSynSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - ClassOpSig _ _ names typ -> - [ case styp of - ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names - _ -> toHie $ map (C $ TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ - ] - IdSig _ _ -> [] - FixSig _ fsig -> - [ toHie $ L sp fsig - ] - InlineSig _ name _ -> - [ toHie $ (C Use) name - ] - SpecSig _ name typs _ -> - [ toHie $ (C Use) name - , toHie $ map (TS (ResolvedScopes [])) typs - ] - SpecInstSig _ _ typ -> - [ toHie $ TS (ResolvedScopes []) typ - ] - MinimalSig _ _ form -> - [ toHie form - ] - SCCFunSig _ _ name mtxt -> - [ toHie $ (C Use) name - , pure $ maybe [] (locOnly . getLoc) mtxt - ] - CompleteMatchSig _ _ (L ispan names) typ -> - [ pure $ locOnly ispan - , toHie $ map (C Use) names - , toHie $ fmap (C Use) typ - ] +instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where + toHie (SC (SI styp msp) (L sp sig)) = + case hiePass @p of + HieTc -> pure [] + HieRn -> concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , maybe (pure []) (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] instance ToHie (LHsType GhcRn) where toHie x = toHie $ TS (ResolvedScopes []) x @@ -1598,21 +1707,21 @@ instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where toHie (HsValArg tm) = toHie tm toHie (HsTypeArg _ ty) = toHie ty - toHie (HsArgPar sp) = pure $ locOnly sp + toHie (HsArgPar sp) = locOnly sp -instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where +instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - UserTyVar _ var -> + UserTyVar _ _ var -> [ toHie $ C (TyVarBind sc tsc) var ] - KindedTyVar _ var kind -> + KindedTyVar _ _ var kind -> [ toHie $ C (TyVarBind sc tsc) var , toHie kind ] instance ToHie (TScoped (LHsQTyVars GhcRn)) where toHie (TS sc (HsQTvs implicits vars)) = concatM $ - [ pure $ bindingsOnly bindings + [ bindingsOnly bindings , toHie $ tvScopes sc NoScope vars ] where @@ -1621,7 +1730,7 @@ instance ToHie (LHsContext GhcRn) where toHie (L span tys) = concatM $ - [ pure $ locOnly span + [ locOnly span , toHie tys ] @@ -1681,11 +1790,7 @@ instance ToHie (Located HsIPName) where toHie (L span e) = makeNode e span -instance ( a ~ GhcPass p - , ToHie (LHsExpr a) - , Data (HsSplice a) - , IsPass p - ) => ToHie (Located (HsSplice a)) where +instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where toHie (L span sp) = concatM $ makeNode sp span : case sp of HsTypedSplice _ _ _ expr -> [ toHie expr @@ -1694,7 +1799,7 @@ [ toHie expr ] HsQuasiQuote _ _ _ ispan _ -> - [ pure $ locOnly ispan + [ locOnly ispan ] HsSpliced _ _ _ -> [] @@ -1710,7 +1815,7 @@ toHie (L span annot) = concatM $ makeNode annot span : case annot of RoleAnnotDecl _ var roles -> [ toHie $ C Use var - , concatMapM (pure . locOnly . getLoc) roles + , concatMapM (locOnly . getLoc) roles ] instance ToHie (LInstDecl GhcRn) where @@ -1730,9 +1835,9 @@ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl - , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl + , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl , toHie $ cid_tyfam_insts decl - , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl + , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl , toHie $ cid_datafam_insts decl , toHie $ cid_overlap_mode decl ] @@ -1784,14 +1889,14 @@ ] instance ToHie ForeignImport where - toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ + toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ [ locOnly a , locOnly b , locOnly c ] instance ToHie ForeignExport where - toHie (CExport (L a _) (L b _)) = pure $ concat $ + toHie (CExport (L a _) (L b _)) = concatM $ [ locOnly a , locOnly b ] @@ -1829,7 +1934,7 @@ instance ToHie (LRuleDecl GhcRn) where toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM [ makeNode r span - , pure $ locOnly $ getLoc rname + , locOnly $ getLoc rname , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs , toHie $ map (RS $ mkScope span) bndrs , toHie exprA @@ -1859,7 +1964,7 @@ ] where goIE (hiding, (L sp liens)) = concatM $ - [ pure $ locOnly sp + [ locOnly sp , toHie $ map (IEC c) liens ] where diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -12,18 +12,17 @@ , HieFileResult(..) , hieMagic , hieNameOcc + , NameCacheUpdater(..) ) where import GHC.Settings.Utils ( maybeRead ) - -import Config ( cProjectVersion ) +import GHC.Settings.Config ( cProjectVersion ) import GHC.Prelude import GHC.Utils.Binary import GHC.Iface.Binary ( getDictFastString ) import GHC.Data.FastMutInt import GHC.Data.FastString ( FastString ) -import GHC.Unit.Module ( Module ) import GHC.Types.Name import GHC.Types.Name.Cache import GHC.Utils.Outputable @@ -32,7 +31,7 @@ import GHC.Types.Unique.Supply ( takeUniqFromSupply ) import GHC.Types.Unique import GHC.Types.Unique.FM -import GHC.Utils.Misc +import GHC.Iface.Env (NameCacheUpdater(..)) import qualified Data.Array as A import Data.IORef @@ -47,42 +46,6 @@ import GHC.Iface.Ext.Types --- | `Name`'s get converted into `HieName`'s before being written into @.hie@ --- files. See 'toHieName' and 'fromHieName' for logic on how to convert between --- these two types. -data HieName - = ExternalName !Module !OccName !SrcSpan - | LocalName !OccName !SrcSpan - | KnownKeyName !Unique - deriving (Eq) - -instance Ord HieName where - compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f - -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.leftmost_smallest b d - -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b - -- Not actually non deterministic as it is a KnownKey - compare ExternalName{} _ = LT - compare LocalName{} ExternalName{} = GT - compare LocalName{} _ = LT - compare KnownKeyName{} _ = GT - -instance Outputable HieName where - ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp - ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp - ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u - -hieNameOcc :: HieName -> OccName -hieNameOcc (ExternalName _ occ _) = occ -hieNameOcc (LocalName occ _) = occ -hieNameOcc (KnownKeyName u) = - case lookupKnownKeyName u of - Just n -> nameOccName n - Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr (unpkUnique u)) - - data HieSymbolTable = HieSymbolTable { hie_symtab_next :: !FastMutInt , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) @@ -189,23 +152,23 @@ -- an existing `NameCache`. Allows you to specify -- which versions of hieFile to attempt to read. -- `Left` case returns the failing header versions. -readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache)) -readHieFileWithVersion readVersion nc file = do +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileWithVersion readVersion ncu file = do bh0 <- readBinMem file (hieVersion, ghcVersion) <- readHieFileHeader file bh0 if readVersion (hieVersion, ghcVersion) then do - (hieFile, nc') <- readHieFileContents bh0 nc - return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc') + hieFile <- readHieFileContents bh0 ncu + return $ Right (HieFileResult hieVersion ghcVersion hieFile) else return $ Left (hieVersion, ghcVersion) -- | Read a `HieFile` from a `FilePath`. Can use -- an existing `NameCache`. -readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache) -readHieFile nc file = do +readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult +readHieFile ncu file = do bh0 <- readBinMem file @@ -219,8 +182,8 @@ , show hieVersion , "but got", show readHieVersion ] - (hieFile, nc') <- readHieFileContents bh0 nc - return $ (HieFileResult hieVersion ghcVersion hieFile, nc') + hieFile <- readHieFileContents bh0 ncu + return $ HieFileResult hieVersion ghcVersion hieFile readBinLine :: BinHandle -> IO ByteString readBinLine bh = BS.pack . reverse <$> loop [] @@ -254,24 +217,24 @@ ] return (readHieVersion, ghcVersion) -readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache) -readHieFileContents bh0 nc = do +readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile +readHieFileContents bh0 ncu = do dict <- get_dictionary bh0 -- read the symbol table so we are capable of reading the actual data - (bh1, nc') <- do + bh1 <- do let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") (getDictFastString dict) - (nc', symtab) <- get_symbol_table bh1 + symtab <- get_symbol_table bh1 let bh1' = setUserData bh1 $ newReadState (getSymTabName symtab) (getDictFastString dict) - return (bh1', nc') + return bh1' -- load the actual data hiefile <- get bh1 - return (hiefile, nc') + return hiefile where get_dictionary bin_handle = do dict_p <- get bin_handle @@ -285,9 +248,9 @@ symtab_p <- get bh1 data_p' <- tellBin bh1 seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 nc + symtab <- getSymbolTable bh1 ncu seekBin bh1 data_p' - return (nc', symtab) + return symtab putFastString :: HieDictionary -> BinHandle -> FastString -> IO () putFastString HieDictionary { hie_dict_next = j_r, @@ -309,13 +272,14 @@ let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) mapM_ (putHieName bh) names -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable) -getSymbolTable bh namecache = do +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do sz <- get bh od_names <- replicateM sz (getHieName bh) - let arr = A.listArray (0,sz-1) names - (namecache', names) = mapAccumR fromHieName namecache od_names - return (namecache', arr) + updateNameCache ncu $ \nc -> + let arr = A.listArray (0,sz-1) names + (nc', names) = mapAccumR fromHieName nc od_names + in (nc',arr) getSymTabName :: SymbolTable -> BinHandle -> IO Name getSymTabName st bh = do @@ -349,14 +313,6 @@ -- ** Converting to and from `HieName`'s - -toHieName :: Name -> HieName -toHieName name - | isKnownKeyName name = KnownKeyName (nameUnique name) - | isExternalName name = ExternalName (nameModule name) - (nameOccName name) - (nameSrcSpan name) - | otherwise = LocalName (nameOccName name) (nameSrcSpan name) fromHieName :: NameCache -> HieName -> (NameCache, Name) fromHieName nc (ExternalName mod occ span) = diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs --- a/compiler/GHC/Iface/Ext/Debug.hs +++ b/compiler/GHC/Iface/Ext/Debug.hs @@ -15,7 +15,6 @@ import GHC.Utils.Outputable import GHC.Iface.Ext.Types -import GHC.Iface.Ext.Binary import GHC.Iface.Ext.Utils import GHC.Types.Name @@ -39,17 +38,18 @@ spanDiff | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] | otherwise = [] - infoDiff' - = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 - ++ (diffList diffType `on` nodeType) info1 info2 - ++ (diffIdents `on` nodeIdentifiers) info1 info2 - infoDiff = case infoDiff' of + infoDiff' i1 i2 + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2 + ++ (diffList diffType `on` nodeType) i1 i2 + ++ (diffIdents `on` nodeIdentifiers) i1 i2 + sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo) + infoDiff = case sinfoDiff info1 info2 of [] -> [] - xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1) - , "and", ppr (nodeIdentifiers info2,span2) + xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1) + , "and", ppr (sourcedNodeIdents info2,span2) , "While comparing" - , ppr (normalizeIdents $ nodeIdentifiers info1), "and" - , ppr (normalizeIdents $ nodeIdentifiers info2) + , ppr (normalizeIdents $ sourcedNodeIdents info1), "and" + , ppr (normalizeIdents $ sourcedNodeIdents info2) ] ] @@ -107,11 +107,24 @@ -- | Look for any identifiers which occur outside of their supposed scopes. -- Returns a list of error messages. validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc] -validateScopes mod asts = validScopes +validateScopes mod asts = validScopes ++ validEvs where refMap = generateReferencesMap asts -- We use a refmap for most of the computation + evs = M.keys + $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap + + validEvs = do + i@(Right ev) <- evs + case M.lookup i refMap of + Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ] + Just refs + | nameIsLocalOrFrom mod ev + , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs) + -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"] + | otherwise -> [] + -- Check if all the names occur in their calculated scopes validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap valid (Left _) _ = [] @@ -122,15 +135,18 @@ Just xs -> xs Nothing -> [] inScope (sp, dets) - | (definedInAsts asts n) + | (definedInAsts asts n || (any isEvidenceContext (identInfo dets))) && any isOccurrence (identInfo dets) -- We validate scopes for names which are defined locally, and occur - -- in this span + -- in this span, or are evidence variables = case scopes of - [] | (nameIsLocalOrFrom mod n - && not (isDerivedOccName $ nameOccName n)) - -- If we don't get any scopes for a local name then its an error. - -- We can ignore derived names. + [] | nameIsLocalOrFrom mod n + , ( not (isDerivedOccName $ nameOccName n) + || any isEvidenceContext (identInfo dets)) + -- If we don't get any scopes for a local name or + -- an evidence variable, then its an error. + -- We can ignore other kinds of derived names as + -- long as we take evidence vars into account -> return $ hsep $ [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp , "Doesn't have a calculated scope: ", ppr scopes] diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -14,16 +14,19 @@ import GHC.Prelude -import Config +import GHC.Settings.Config import GHC.Utils.Binary import GHC.Data.FastString ( FastString ) +import GHC.Builtin.Utils import GHC.Iface.Type -import GHC.Unit.Module ( ModuleName, Module ) -import GHC.Types.Name ( Name ) +import GHC.Unit.Module ( ModuleName, Module ) +import GHC.Types.Name import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Types.SrcLoc ( RealSrcSpan ) +import GHC.Types.SrcLoc import GHC.Types.Avail +import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) +import GHC.Utils.Misc import qualified Data.Array as A import qualified Data.Map as M @@ -33,6 +36,8 @@ import Data.Semigroup ( Semigroup(..) ) import Data.Word ( Word8 ) import Control.Applicative ( (<|>) ) +import Data.Coerce ( coerce ) +import Data.Function ( on ) type Span = RealSrcSpan @@ -222,17 +227,16 @@ , rest ] - data HieAST a = Node - { nodeInfo :: NodeInfo a + { sourcedNodeInfo :: SourcedNodeInfo a , nodeSpan :: Span , nodeChildren :: [HieAST a] } deriving (Functor, Foldable, Traversable) instance Binary (HieAST TypeIndex) where put_ bh ast = do - put_ bh $ nodeInfo ast + put_ bh $ sourcedNodeInfo ast put_ bh $ nodeSpan ast put_ bh $ nodeChildren ast @@ -247,6 +251,38 @@ header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni rest = vcat (map ppr ch) + +-- | NodeInfos grouped by source +newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) } + deriving (Functor, Foldable, Traversable) + +instance Binary (SourcedNodeInfo TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts + get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (SourcedNodeInfo a) where + ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "Source: " O.<> ppr k + , ppr a + , rest + ] + +-- | Source of node info +data NodeOrigin + = SourceInfo + | GeneratedInfo + deriving (Eq, Enum, Ord) + +instance Outputable NodeOrigin where + ppr SourceInfo = text "From source" + ppr GeneratedInfo = text "generated by ghc" + +instance Binary NodeOrigin where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + -- | The information stored in one AST node. -- -- The type parameter exists to provide flexibility in representation of types @@ -314,7 +350,7 @@ instance Binary (IdentifierDetails TypeIndex) where put_ bh dets = do put_ bh $ identType dets - put_ bh $ S.toAscList $ identInfo dets + put_ bh $ S.toList $ identInfo dets get bh = IdentifierDetails <$> get bh <*> fmap S.fromDistinctAscList (get bh) @@ -363,6 +399,14 @@ -- | Record field | RecField RecFieldContext (Maybe Span) + -- | Constraint/Dictionary evidence variable binding + | EvidenceVarBind + EvVarSource -- ^ how did this bind come into being + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of the binding site + + -- | Usage of evidence variable + | EvidenceVarUse deriving (Eq, Ord) instance Outputable ContextInfo where @@ -385,10 +429,16 @@ <+> ppr sc1 <+> "," <+> ppr sc2 ppr (RecField ctx sp) = text "record field" <+> ppr ctx <+> pprBindSpan sp + ppr (EvidenceVarBind ctx sc sp) = + text "evidence variable" <+> ppr ctx + $$ "with scope:" <+> ppr sc + $$ pprBindSpan sp + ppr (EvidenceVarUse) = + text "usage of evidence variable" pprBindSpan :: Maybe Span -> SDoc pprBindSpan Nothing = text "" -pprBindSpan (Just sp) = text "at:" <+> ppr sp +pprBindSpan (Just sp) = text "bound at:" <+> ppr sp instance Binary ContextInfo where put_ bh Use = putByte bh 0 @@ -422,6 +472,12 @@ put_ bh a put_ bh b put_ bh MatchBind = putByte bh 9 + put_ bh (EvidenceVarBind a b c) = do + putByte bh 10 + put_ bh a + put_ bh b + put_ bh c + put_ bh EvidenceVarUse = putByte bh 11 get bh = do (t :: Word8) <- get bh @@ -436,8 +492,69 @@ 7 -> TyVarBind <$> get bh <*> get bh 8 -> RecField <$> get bh <*> get bh 9 -> return MatchBind + 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh + 11 -> return EvidenceVarUse _ -> panic "Binary ContextInfo: invalid tag" +data EvVarSource + = EvPatternBind -- ^ bound by a pattern match + | EvSigBind -- ^ bound by a type signature + | EvWrapperBind -- ^ bound by a hswrapper + | EvImplicitBind -- ^ bound by an implicit variable + | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class + | EvLetBind EvBindDeps -- ^ A direct let binding + deriving (Eq,Ord) + +instance Binary EvVarSource where + put_ bh EvPatternBind = putByte bh 0 + put_ bh EvSigBind = putByte bh 1 + put_ bh EvWrapperBind = putByte bh 2 + put_ bh EvImplicitBind = putByte bh 3 + put_ bh (EvInstBind b cls) = do + putByte bh 4 + put_ bh b + put_ bh cls + put_ bh (EvLetBind deps) = do + putByte bh 5 + put_ bh deps + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> pure EvPatternBind + 1 -> pure EvSigBind + 2 -> pure EvWrapperBind + 3 -> pure EvImplicitBind + 4 -> EvInstBind <$> get bh <*> get bh + 5 -> EvLetBind <$> get bh + _ -> panic "Binary EvVarSource: invalid tag" + +instance Outputable EvVarSource where + ppr EvPatternBind = text "bound by a pattern" + ppr EvSigBind = text "bound by a type signature" + ppr EvWrapperBind = text "bound by a HsWrapper" + ppr EvImplicitBind = text "bound by an implicit variable binding" + ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls + ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls + ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps + +-- | Eq/Ord instances compare on the converted HieName, +-- as non-exported names may have different uniques after +-- a roundtrip +newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] } + deriving Outputable + +instance Eq EvBindDeps where + (==) = coerce ((==) `on` map toHieName) + +instance Ord EvBindDeps where + compare = coerce (compare `on` map toHieName) + +instance Binary EvBindDeps where + put_ bh (EvBindDeps xs) = put_ bh xs + get bh = EvBindDeps <$> get bh + + -- | Types of imports and exports data IEType = Import @@ -587,3 +704,46 @@ 0 -> ResolvedScopes <$> get bh 1 -> UnresolvedScope <$> get bh <*> get bh _ -> panic "Binary TyVarScope: invalid tag" + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non deterministic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr (unpkUnique u)) + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (nameSrcSpan name) diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} module GHC.Iface.Ext.Utils where import GHC.Prelude @@ -11,7 +13,9 @@ import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type import GHC.Types.Name hiding (varName) -import GHC.Utils.Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) +import GHC.Types.Name.Set +import GHC.Utils.Outputable hiding ( (<>) ) +import qualified GHC.Utils.Outputable as O import GHC.Types.SrcLoc import GHC.CoreToIface import GHC.Core.TyCon @@ -27,25 +31,29 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Array as A import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) -import Data.Maybe ( maybeToList ) +import Data.Maybe ( maybeToList, mapMaybe) import Data.Monoid +import Data.List (find) import Data.Traversable ( for ) +import Data.Coerce import Control.Monad.Trans.State.Strict hiding (get) +import Control.Monad.Trans.Reader +import qualified Data.Tree as Tree +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] generateReferencesMap :: Foldable f => f (HieAST a) - -> M.Map Identifier [(Span, IdentifierDetails a)] + -> RefMap a generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty where go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) where - this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast + this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast renderHieType :: DynFlags -> HieTypeFix -> String -renderHieType df ht = renderWithStyle (initSDocContext df sty) (ppr $ hieTypeToIface ht) - where sty = defaultUserStyle df +renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht) resolveVisibility :: Type -> [Type] -> [(Bool,Type)] resolveVisibility kind ty_args @@ -73,6 +81,73 @@ foldType :: (HieType a -> a) -> HieTypeFix -> a foldType f (Roll t) = f $ fmap (foldType f) t +selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int) +selectPoint hf (sl,sc) = getFirst $ + flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $ + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just ast' + where + sloc fs = mkRealSrcLoc fs sl sc + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + +findEvidenceUse :: NodeIdentifiers a -> [Name] +findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)] + where + xs = M.toList ni + +data EvidenceInfo a + = EvidenceInfo + { evidenceVar :: Name + , evidenceSpan :: RealSrcSpan + , evidenceType :: a + , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span) + } deriving (Eq,Ord,Functor) + +instance (Outputable a) => Outputable (EvidenceInfo a) where + ppr (EvidenceInfo name span typ dets) = + hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $ + pdets $$ (pprDefinedAt name) + where + pdets = case dets of + Nothing -> text "is a usage of an external evidence variable" + Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn) + +getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a) +getEvidenceTreesAtPoint hf refmap point = + [t | Just ast <- pure $ selectPoint hf point + , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast) + , Just t <- pure $ getEvidenceTree refmap n + ] + +getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a)) +getEvidenceTree refmap var = go emptyNameSet var + where + go seen var + | var `elemNameSet` seen = Nothing + | otherwise = do + xs <- M.lookup (Right var) refmap + case find (any isEvidenceBind . identInfo . snd) xs of + Just (sp,dets) -> do + typ <- identType dets + (evdet,children) <- getFirst $ foldMap First $ do + det <- S.toList $ identInfo dets + case det of + EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn -> + pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs) + EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[]) + _ -> pure Nothing + pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children + -- It is externally bound + Nothing -> getFirst $ foldMap First $ do + (sp,dets) <- xs + if (any isEvidenceUse $ identInfo dets) + then do + case identType dets of + Nothing -> pure Nothing + Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) [] + else pure Nothing + hieTypeToIface :: HieTypeFix -> IfaceType hieTypeToIface = foldType go where @@ -195,8 +270,10 @@ resolveScope scope = scope go (Node info span children) = Node info' span $ map go children where - info' = info { nodeIdentifiers = idents } - idents = M.map resolveNameScope $ nodeIdentifiers info + info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info) + updateNodeInfo i = i { nodeIdentifiers = idents } + where + idents = M.map resolveNameScope $ nodeIdentifiers i getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span getNameBinding n asts = do @@ -218,7 +295,7 @@ getFirst $ foldMap First $ do child <- flattenAst ast dets <- maybeToList - $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) return (getFirst binding) @@ -233,7 +310,7 @@ getFirst $ foldMap First $ do -- @[] node <- flattenAst defNode dets <- maybeToList - $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) return $ Just (scopes, getFirst binding) @@ -246,6 +323,7 @@ getScopeFromContext (Decl _ _) = Just [ModuleScope] getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs getScopeFromContext (TyVarBind a _) = Just [a] +getScopeFromContext (EvidenceVarBind _ a _) = Just [a] getScopeFromContext _ = Nothing getBindSiteFromContext :: ContextInfo -> Maybe Span @@ -293,8 +371,27 @@ RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts _ -> False +getEvidenceBindDeps :: ContextInfo -> [Name] +getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) = + getEvBindDeps xs +getEvidenceBindDeps _ = [] + +isEvidenceBind :: ContextInfo -> Bool +isEvidenceBind EvidenceVarBind{} = True +isEvidenceBind _ = False + +isEvidenceContext :: ContextInfo -> Bool +isEvidenceContext EvidenceVarUse = True +isEvidenceContext EvidenceVarBind{} = True +isEvidenceContext _ = False + +isEvidenceUse :: ContextInfo -> Bool +isEvidenceUse EvidenceVarUse = True +isEvidenceUse _ = False + isOccurrence :: ContextInfo -> Bool isOccurrence Use = True +isOccurrence EvidenceVarUse = True isOccurrence _ = False scopeContainsSpan :: Scope -> Span -> Bool @@ -305,7 +402,7 @@ -- | One must contain the other. Leaf nodes cannot contain anything combineAst :: HieAST Type -> HieAST Type -> HieAST Type combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) - | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys) + | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys) | aSpn `containsSpan` bSpn = combineAst b a combineAst a (Node xs span children) = Node xs span (insertAst a children) @@ -313,6 +410,18 @@ insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] insertAst x = mergeAsts [x] +nodeInfo :: HieAST Type -> NodeInfo Type +nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo + +emptyNodeInfo :: NodeInfo a +emptyNodeInfo = NodeInfo S.empty [] M.empty + +sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a +sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo + +combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type +combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo + -- | Merge two nodes together. -- -- Precondition and postcondition: elements in 'nodeType' are ordered. @@ -405,11 +514,12 @@ simpleNodeInfo :: FastString -> FastString -> NodeInfo a simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty -locOnly :: SrcSpan -> [HieAST a] -locOnly (RealSrcSpan span _) = - [Node e span []] - where e = NodeInfo S.empty [] M.empty -locOnly _ = [] +locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a] +locOnly (RealSrcSpan span _) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] +locOnly _ = pure [] mkScope :: SrcSpan -> Scope mkScope (RealSrcSpan sp _) = LocalScope sp @@ -426,30 +536,37 @@ combineScopes (LocalScope a) (LocalScope b) = mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing) +mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a +mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni + {-# INLINEABLE makeNode #-} makeNode - :: (Applicative m, Data a) + :: (Monad m, Data a) => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') -> SrcSpan -- ^ return an empty list if this is unhelpful - -> m [HieAST b] -makeNode x spn = pure $ case spn of - RealSrcSpan span _ -> [Node (simpleNodeInfo cons typ) span []] - _ -> [] + -> ReaderT NodeOrigin m [HieAST b] +makeNode x spn = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + _ -> [] where cons = mkFastString . show . toConstr $ x typ = mkFastString . show . typeRepTyCon . typeOf $ x {-# INLINEABLE makeTypeNode #-} makeTypeNode - :: (Applicative m, Data a) + :: (Monad m, Data a) => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') -> SrcSpan -- ^ return an empty list if this is unhelpful -> Type -- ^ type to associate with the node - -> m [HieAST Type] -makeTypeNode x spn etyp = pure $ case spn of - RealSrcSpan span _ -> - [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] - _ -> [] + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNode x spn etyp = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] + _ -> [] where cons = mkFastString . show . toConstr $ x typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -32,7 +32,7 @@ ifaceStats, pprModIface, showIface ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -991,7 +991,6 @@ readIface wanted_mod file_path = do { res <- tryMostM $ readBinIface CheckHiWay QuietBinIFaceReading file_path - ; dflags <- getDynFlags ; case res of Right iface -- NB: This check is NOT just a sanity check, it is @@ -1002,7 +1001,7 @@ | otherwise -> return (Failed err) where actual_mod = mi_module iface - err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod + err = hiModuleNameMismatchWarn wanted_mod actual_mod Left exn -> return (Failed (text (showException exn))) } @@ -1118,7 +1117,7 @@ neverQualifyModules neverQualifyPackages putLogMsg dflags NoReason SevDump noSrcSpan - (mkDumpStyle dflags print_unqual) (pprModIface iface) + $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface) -- Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT. @@ -1270,8 +1269,8 @@ = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc -hiModuleNameMismatchWarn dflags requested_mod read_mod +hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc +hiModuleNameMismatchWarn requested_mod read_mod | moduleUnit requested_mod == moduleUnit read_mod = sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, text "but we were expecting module" <+> quotes (ppr requested_mod), @@ -1282,7 +1281,7 @@ | otherwise = -- ToDo: This will fail to have enough qualification when the package IDs -- are the same - withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, -- so reset the PrintUnqualified setting. hsep [ text "Something is amiss; requested module " diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -19,7 +19,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -100,7 +100,7 @@ -- | Fully instantiate a interface -- Adds fingerprints and potentially code generator produced information. -mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface +mkFullIface :: HscEnv -> PartialModIface -> Maybe NonCaffySet -> IO ModIface mkFullIface hsc_env partial_iface mb_non_cafs = do let decls | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) @@ -117,9 +117,9 @@ return full_iface -updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl] +updateDeclCafInfos :: [IfaceDecl] -> Maybe NonCaffySet -> [IfaceDecl] updateDeclCafInfos decls Nothing = decls -updateDeclCafInfos decls (Just non_cafs) = map update_decl decls +updateDeclCafInfos decls (Just (NonCaffySet non_cafs)) = map update_decl decls where update_decl decl | IfaceId nm ty details infos <- decl @@ -574,7 +574,7 @@ -- tidying produced. Therefore, tidying the user-written tyvars is a -- simple matter of looking up each variable in the substitution, -- which tidyTyCoVarOcc accomplishes. - tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder + tidyUserTyCoVarBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder tidyUserTyCoVarBinder env (Bndr tv vis) = Bndr (tidyTyCoVarOcc env tv) vis diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -10,7 +10,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -615,14 +615,14 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, usg_file_hash = old_hash } = liftIO $ - handleIO handle $ do + handleIO handler $ do new_hash <- getFileHash file if (old_hash /= new_hash) then return recomp else return UpToDate where - recomp = RecompBecause (file ++ " changed") - handle = + recomp = RecompBecause (file ++ " changed") + handler = #if defined(DEBUG) \e -> pprTrace "UsageFile" (text (show e)) $ return recomp #else diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -15,7 +15,7 @@ tcRnModExports, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -735,7 +735,7 @@ rnIfaceType (IfaceCastTy ty co) = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co -rnIfaceForAllBndr :: Rename IfaceForAllBndr +rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag) rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis rnIfaceAppArgs :: Rename IfaceAppArgs diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -12,7 +12,7 @@ mkBootModDetailsTc, tidyProgram ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -29,7 +29,7 @@ import GHC.Core.Rules import GHC.Core.PatSyn import GHC.Core.ConLike -import GHC.Core.Arity ( exprArity, exprBotStrictness_maybe ) +import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) import GHC.Iface.Tidy.StaticPtrTable import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -39,7 +39,7 @@ import GHC.Types.Id.Info import GHC.Core.InstEnv import GHC.Core.Type ( tidyTopType ) -import GHC.Types.Demand ( appIsBottom, isTopSig, isBottomingSig ) +import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) @@ -437,7 +437,7 @@ Err.dumpIfSet_dyn dflags Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) Err.FormatText - (pprRulesForUser dflags tidy_rules) + (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds @@ -726,7 +726,7 @@ show_unfold = show_unfolding unfolding never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isStrongLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingSig (strictnessInfo idinfo) + bottoming_fn = isDeadEndSig (strictnessInfo idinfo) -- Stuff to do with the Id's unfolding -- We leave the unfolding there even if there is a worker @@ -1229,7 +1229,7 @@ _bottom_hidden id_sig = case mb_bot_str of Nothing -> False - Just (arity, _) -> not (appIsBottom id_sig arity) + Just (arity, _) -> not (appIsDeadEnd id_sig arity) --------- Unfolding ------------ unf_info = unfoldingInfo idinfo diff --git a/compiler/GHC/Iface/UpdateCafInfos.hs b/compiler/GHC/Iface/UpdateCafInfos.hs --- a/compiler/GHC/Iface/UpdateCafInfos.hs +++ b/compiler/GHC/Iface/UpdateCafInfos.hs @@ -18,12 +18,12 @@ import GHC.Types.Var import GHC.Utils.Outputable -#include "HsVersions.h" +#include "GhclibHsVersions.h" -- | Update CafInfos of all occurences (in rules, unfoldings, class instances) updateModDetailsCafInfos :: DynFlags - -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. + -> NonCaffySet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. -> ModDetails -- ^ ModDetails to update -> ModDetails @@ -31,7 +31,7 @@ | gopt Opt_OmitInterfacePragmas dflags = mod_details -updateModDetailsCafInfos _ non_cafs mod_details = +updateModDetailsCafInfos _ (NonCaffySet non_cafs) mod_details = {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} let ModDetails{ md_types = type_env -- for unfoldings diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -22,7 +22,7 @@ tcIfaceGlobal ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -36,6 +36,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Coercion.Axiom +import GHC.Core.FVs import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Driver.Types @@ -894,7 +895,7 @@ ; mkNewTyConRhs tycon_name tycon data_con } where univ_tvs :: [TyVar] - univ_tvs = binderVars (tyConTyVarBinders tc_tybinders) + univ_tvs = binderVars tc_tybinders tag_map :: NameEnv ConTag tag_map = mkTyConTagMap tycon @@ -1061,8 +1062,24 @@ -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (text "Rule" <+> pprRuleName name) $ bindIfaceBndrs bndrs $ \ bndrs' -> - do { args' <- mapM tcIfaceExpr args - ; rhs' <- tcIfaceExpr rhs + do { args' <- mapM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; whenGOptM Opt_DoCoreLinting $ do + { dflags <- getDynFlags + ; (_, lcl_env) <- getEnvs + ; let in_scope :: [Var] + in_scope = ((nonDetEltsUFM $ if_tv_env lcl_env) ++ + (nonDetEltsUFM $ if_id_env lcl_env) ++ + bndrs' ++ + exprsFreeIdsList args') + ; case lintExpr dflags in_scope rhs' of + Nothing -> return () + Just fail_msg -> do { mod <- getIfModule + ; pprPanic "Iface Lint failure" + (vcat [ text "In interface for" <+> ppr mod + , hang doc 2 fail_msg + , ppr name <+> equals <+> ppr rhs' + , text "Iface expr =" <+> ppr rhs ]) } } ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args ; this_mod <- getIfModule @@ -1091,6 +1108,8 @@ ifTopFreeName (IfaceExt n) = Just n ifTopFreeName _ = Nothing + doc = text "Unfolding of" <+> ppr name + {- ************************************************************************ * * @@ -1771,14 +1790,14 @@ thing_inside (b':bs') ----------------------- -bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a +bindIfaceForAllBndrs :: [VarBndr IfaceBndr vis] -> ([VarBndr TyCoVar vis] -> IfL a) -> IfL a bindIfaceForAllBndrs [] thing_inside = thing_inside [] bindIfaceForAllBndrs (bndr:bndrs) thing_inside = bindIfaceForAllBndr bndr $ \tv vis -> bindIfaceForAllBndrs bndrs $ \bndrs' -> - thing_inside (mkTyCoVarBinder vis tv : bndrs') + thing_inside (Bndr tv vis : bndrs') -bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a +bindIfaceForAllBndr :: (VarBndr IfaceBndr vis) -> (TyCoVar -> vis -> IfL a) -> IfL a bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -23,7 +23,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -7,7 +7,7 @@ module GHC.Llvm.Types where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -48,6 +48,7 @@ , module GHC.Utils.Outputable , module GHC.Types.Unique.Supply , module GHC.Data.FastString + , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins , -- * Getting 'Name's thNameToGhcName ) @@ -92,7 +93,7 @@ import GHC.Core.TyCon import GHC.Builtin.Types import GHC.Driver.Types -import GHC.Types.Basic hiding ( Version {- conflicts with Packages.Version -} ) +import GHC.Types.Basic -- Collections and maps import GHC.Types.Var.Set @@ -120,6 +121,8 @@ import GHC.Utils.Monad ( mapMaybeM ) import GHC.ThToHs ( thRdrNameGuesses ) import GHC.Tc.Utils.Env ( lookupGlobal ) + +import GHC.Tc.Errors.Hole.FitTypes import qualified Language.Haskell.TH as TH diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -869,8 +869,7 @@ -- Rename the bindings RHSs. Again there's an issue about whether the -- type variables from the class/instance head are in scope. -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables - ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables - ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ + ; (binds'', bind_fvs) <- bindSigTyVarsFV ktv_names $ do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) emptyFVs binds_w_dus @@ -878,12 +877,6 @@ ; return ( binds'', spec_inst_prags' ++ other_sigs' , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } - where - -- For the method bindings in class and instance decls, we extend - -- the type variable environment iff -XScopedTypeVariables - maybe_extend_tyvar_env scoped_tvs thing_inside - | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside - | otherwise = thing_inside rnMethodBindLHS :: Bool -> Name -> LHsBindLR GhcPs GhcPs @@ -962,7 +955,7 @@ renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) - ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty + ; (new_ty, fvs) <- rnHsSigWcType doc Nothing ty ; return (TypeSig noExtField new_vs new_ty, fvs) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) @@ -970,16 +963,21 @@ ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel inf_msg ty ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } where (v1:_) = vs ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) + inf_msg = if is_deflt + then Just (text "A default type signature cannot contain inferred type variables") + else Nothing renameSig _ (SpecInstSig _ src ty) - = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty + = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel inf_msg ty ; return (SpecInstSig noExtField src new_ty,fvs) } + where + inf_msg = Just (text "Inferred type variables are not allowed") -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -995,7 +993,7 @@ ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v)) do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty + = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel Nothing ty ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig _ v s) @@ -1012,7 +1010,7 @@ renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel Nothing ty ; return (PatSynSig noExtField new_vs ty', fvs) } where ty_ctxt = GenericCtx (text "a pattern synonym signature for" diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -42,7 +42,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -24,7 +24,7 @@ rnLExpr, rnExpr, rnStmts ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -316,7 +316,7 @@ , fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig _ expr pty) - = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty + = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx Nothing pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } @@ -1335,7 +1335,7 @@ = (reverse yeses, reverse noes) where (noes, yeses) = span not_needed (reverse dus) - not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) + not_needed (defs,_,_,_) = disjointNameSet defs uses ---------------------------------------------------- segsToStmts :: Stmt GhcRn body @@ -1889,7 +1889,7 @@ -- then we have actually done some splitting. Otherwise it will go into -- an infinite loop (#14163). go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) + | disjointNameSet bndrs fvs && not (isStrictPattern pat) = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) bndrs' rest where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) @@ -1899,7 +1899,7 @@ -- TODO: perhaps we shouldn't do this if there are any strict bindings, -- because we might be moving evaluation earlier. go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) + | disjointNameSet bndrs fvs = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest go _ [] _ _ = Nothing go _ [_] _ _ = Nothing diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -13,7 +13,7 @@ rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsTypeArgs, rnHsSigType, rnHsWcType, - HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, + HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType, newTyVarNameRn, rnConDeclFields, rnLTyVar, @@ -29,13 +29,14 @@ extractHsTysRdrTyVarsDups, extractRdrKindSigVars, extractDataDefnKindVars, extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup, - nubL, elemRdr + forAllOrNothing, nubL ) where import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) +import GHC.Core.Type import GHC.Driver.Session import GHC.Hs import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) @@ -64,83 +65,120 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import Data.List ( nubBy, partition, (\\) ) +import Data.List ( nubBy, partition, find ) import Control.Monad ( unless, when ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, -to break several loop. +to break several loops. ********************************************************* * * - HsSigWcType (i.e with wildcards) + HsSigWcType and HsPatSigType (i.e with wildcards) * * ********************************************************* -} -data HsSigWcTypeScoping = AlwaysBind - -- ^ Always bind any free tyvars of the given type, - -- regardless of whether we have a forall at the top - | BindUnlessForall - -- ^ Unless there's forall at the top, do the same - -- thing as 'AlwaysBind' - | NeverBind - -- ^ Never bind any free tyvars +data HsSigWcTypeScoping + = AlwaysBind + -- ^ Always bind any free tyvars of the given type, regardless of whether we + -- have a forall at the top. + -- + -- For pattern type sigs, we /do/ want to bring those type + -- variables into scope, even if there's a forall at the top which usually + -- stops that happening, e.g: + -- + -- > \ (x :: forall a. a -> b) -> e + -- + -- Here we do bring 'b' into scope. + -- + -- RULES can also use 'AlwaysBind', such as in the following example: + -- + -- > {-# RULES \"f\" forall (x :: forall a. a -> b). f x = ... b ... #-} + -- + -- This only applies to RULES that do not explicitly bind their type + -- variables. If a RULE explicitly quantifies its type variables, then + -- 'NeverBind' is used instead. See also + -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Type". + | BindUnlessForall + -- ^ Unless there's forall at the top, do the same thing as 'AlwaysBind'. + -- This is only ever used in places where the \"@forall@-or-nothing\" rule + -- is in effect. See @Note [forall-or-nothing rule]@. + | NeverBind + -- ^ Never bind any free tyvars. This is used for RULES that have both + -- explicit type and term variable binders, e.g.: + -- + -- > {-# RULES \"const\" forall a. forall (x :: a) y. const x y = x #-} + -- + -- The presence of the type variable binder @forall a.@ implies that the + -- free variables in the types of the term variable binders @x@ and @y@ + -- are /not/ bound. In the example above, there are no such free variables, + -- but if the user had written @(y :: b)@ instead of @y@ in the term + -- variable binders, then @b@ would be rejected for being out of scope. + -- See also @Note [Pattern signature binders and scoping]@ in + -- "GHC.Hs.Type". -rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs +rnHsSigWcType :: HsDocContext + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. + -> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars) -rnHsSigWcType scoping doc sig_ty - = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' -> - return (sig_ty', emptyFVs) +rnHsSigWcType doc inf_err (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) + = rn_hs_sig_wc_type BindUnlessForall doc inf_err hs_ty $ \nwcs imp_tvs body -> + let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body } + wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in + pure (wc_ty, emptyFVs) -rnHsSigWcTypeScoped :: HsSigWcTypeScoping - -- AlwaysBind: for pattern type sigs and rules we /do/ want - -- to bring those type variables into scope, even - -- if there's a forall at the top which usually - -- stops that happening - -- e.g \ (x :: forall a. a-> b) -> e - -- Here we do bring 'b' into scope - -> HsDocContext -> LHsSigWcType GhcPs - -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) +rnHsPatSigType :: HsSigWcTypeScoping + -> HsDocContext -> Maybe SDoc + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Used for --- - Signatures on binders in a RULE --- - Pattern type signatures +-- - Pattern type signatures, which are only allowed with ScopedTypeVariables +-- - Signatures on binders in a RULE, which are allowed even if +-- ScopedTypeVariables isn't enabled -- Wildcards are allowed --- type signatures on binders only allowed with ScopedTypeVariables -rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside +-- +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +rnHsPatSigType scoping ctx inf_err sig_ty thing_inside = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables - ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) - ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside - } + ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty) + ; rn_hs_sig_wc_type scoping ctx inf_err (hsPatSigType sig_ty) $ + \nwcs imp_tvs body -> + do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs } + sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = body } + ; thing_inside sig_ty' + } } -rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs - -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) +-- The workhorse for rnHsSigWcType and rnHsPatSigType. +rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> Maybe SDoc + -> LHsType GhcPs + -> ([Name] -- Wildcard names + -> [Name] -- Implicitly bound type variable names + -> LHsType GhcRn + -> RnM (a, FreeVars)) -> RnM (a, FreeVars) --- rn_hs_sig_wc_type is used for source-language type signatures -rn_hs_sig_wc_type scoping ctxt - (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) - thing_inside - = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty +rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside + = do { check_inferred_vars ctxt inf_err hs_ty + ; free_vars <- filterInScopeM (extractHsTyRdrTyVarsDups hs_ty) ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' - bind_free_tvs = case scoping of - AlwaysBind -> True - BindUnlessForall -> not (isLHsForAllTy hs_ty) - NeverBind -> False - ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> + ; implicit_bndrs <- case scoping of + AlwaysBind -> pure tv_rdrs + BindUnlessForall -> forAllOrNothing (isLHsForAllTy hs_ty) tv_rdrs + NeverBind -> pure [] + ; rnImplicitBndrs implicit_bndrs $ \ vars -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } - ib_ty' = HsIB { hsib_ext = vars - , hsib_body = hs_ty' } - ; (res, fvs2) <- thing_inside sig_ty' + ; (res, fvs2) <- thing_inside wcs vars hs_ty' ; return (res, fvs1 `plusFV` fvs2) } } rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) - = do { free_vars <- extractFilteredRdrTyVars hs_ty + = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) ; (nwc_rdrs, _) <- partition_nwcs free_vars ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } @@ -240,22 +278,6 @@ StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls _ -> False --- | Finds free type and kind variables in a type, --- without duplicates, and --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups -extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty) - --- | Finds free type and kind variables in a type, --- with duplicates, but --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups -extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty) - -- | When the NamedWildCards extension is enabled, partition_nwcs -- removes type variables that start with an underscore from the -- FreeKiTyVars in the argument and returns them in a separate list. @@ -276,7 +298,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Identifiers starting with an underscore are always parsed as type variables. It is only here in the renamer that we give the special treatment. -See Note [The wildcard story for types] in GHC.Hs.Types. +See Note [The wildcard story for types] in GHC.Hs.Type. It's easy! When we collect the implicitly bound type variables, ready to bring them into scope, and NamedWildCards is on, we partition the @@ -293,47 +315,96 @@ rnHsSigType :: HsDocContext -> TypeOrKind + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards -rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) +rnHsSigType ctx level inf_err (HsIB { hsib_body = hs_ty }) = do { traceRn "rnHsSigType" (ppr hs_ty) - ; vars <- extractFilteredRdrTyVarsDups hs_ty - ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars -> + ; rdr_env <- getLocalRdrEnv + ; check_inferred_vars ctx inf_err hs_ty + ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty) + $ filterInScope rdr_env + $ extractHsTyRdrTyVarsDups hs_ty + ; rnImplicitBndrs vars0 $ \ vars -> do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty ; return ( HsIB { hsib_ext = vars , hsib_body = body' } , fvs ) } } -rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables - -- E.g. f :: forall a. a->b - -- we do not want to bring 'b' into scope, hence False - -- But f :: a -> b - -- we want to bring both 'a' and 'b' into scope +-- Note [forall-or-nothing rule] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Free variables in signatures are usually bound in an implicit +-- 'forall' at the beginning of user-written signatures. However, if the +-- signature has an explicit forall at the beginning, this is disabled. +-- +-- The idea is nested foralls express something which is only +-- expressible explicitly, while a top level forall could (usually) be +-- replaced with an implicit binding. Top-level foralls alone ("forall.") are +-- therefore an indication that the user is trying to be fastidious, so +-- we don't implicitly bind any variables. + +-- | See @Note [forall-or-nothing rule]@. This tiny little function is used +-- (rather than its small body inlined) to indicate that we are implementing +-- that rule. +forAllOrNothing :: Bool + -- ^ True <=> explicit forall + -- E.g. f :: forall a. a->b + -- we do not want to bring 'b' into scope, hence True + -- But f :: a -> b + -- we want to bring both 'a' and 'b' into scope, hence False -> FreeKiTyVarsWithDups - -- Free vars of hs_ty (excluding wildcards) - -- May have duplicates, which is - -- checked here + -- ^ Free vars of the type + -> RnM FreeKiTyVarsWithDups +forAllOrNothing has_outer_forall fvs = case has_outer_forall of + True -> do + traceRn "forAllOrNothing" $ text "has explicit outer forall" + pure [] + False -> do + traceRn "forAllOrNothing" $ text "no explicit forall. implicit binders:" <+> ppr fvs + pure fvs + +rnImplicitBndrs :: FreeKiTyVarsWithDups + -- ^ Surface-syntax free vars that we will implicitly bind. + -- May have duplicates, which is checked here -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rnImplicitBndrs bind_free_tvs - fvs_with_dups +rnImplicitBndrs implicit_vs_with_dups thing_inside - = do { let fvs = nubL fvs_with_dups - real_fvs | bind_free_tvs = fvs - | otherwise = [] + = do { let implicit_vs = nubL implicit_vs_with_dups ; traceRn "rnImplicitBndrs" $ - vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] + vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] ; loc <- getSrcSpanM - ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) implicit_vs ; bindLocalNamesFV vars $ thing_inside vars } +check_inferred_vars :: HsDocContext + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. + -> LHsType GhcPs + -> RnM () +check_inferred_vars _ Nothing _ = return () +check_inferred_vars ctxt (Just msg) ty = + let bndrs = forallty_bndrs ty + in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of + Nothing -> return () + Just _ -> addErr $ withHsDocContext ctxt msg + where + forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs] + forallty_bndrs (L _ ty) = case ty of + HsParTy _ ty' -> forallty_bndrs ty' + HsForAllTy { hst_bndrs = tvs } -> map unLoc tvs + _ -> [] + {- ****************************************************** * * LHsType and HsType @@ -798,21 +869,20 @@ ; let -- See Note [bindHsQTyVars examples] for what -- all these various things are doing - bndrs, kv_occs, implicit_kvs :: [Located RdrName] + bndrs, implicit_kvs :: [Located RdrName] bndrs = map hsLTyVarLocName hs_tv_bndrs - kv_occs = nubL (bndr_kv_occs ++ body_kv_occs) - -- Make sure to list the binder kvs before the - -- body kvs, as mandated by - -- Note [Ordering of implicit variables] - implicit_kvs = filter_occs bndrs kv_occs + implicit_kvs = nubL $ filterFreeVarsToBind bndrs $ + bndr_kv_occs ++ body_kv_occs del = deleteBys eqLocated - all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs) + body_remaining = (body_kv_occs `del` bndrs) `del` bndr_kv_occs + all_bound_on_lhs = null body_remaining ; traceRn "checkMixedVars3" $ - vcat [ text "kv_occs" <+> ppr kv_occs - , text "bndrs" <+> ppr hs_tv_bndrs + vcat [ text "bndrs" <+> ppr hs_tv_bndrs , text "bndr_kv_occs" <+> ppr bndr_kv_occs - , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) + , text "body_kv_occs" <+> ppr body_kv_occs + , text "implicit_kvs" <+> ppr implicit_kvs + , text "body_remaining" <+> ppr body_remaining ] ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs @@ -824,17 +894,6 @@ , hsq_explicit = rn_bndrs }) all_bound_on_lhs } } - where - filter_occs :: [Located RdrName] -- Bound here - -> [Located RdrName] -- Potential implicit binders - -> [Located RdrName] -- Final implicit binders - -- Filter out any potential implicit binders that are either - -- already in scope, or are explicitly bound in the same HsQTyVars - filter_occs bndrs occs - = filterOut is_in_scope occs - where - is_in_scope locc = locc `elemRdr` bndrs - {- Note [bindHsQTyVars examples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -863,7 +922,7 @@ * Order is not important in these lists. All we are doing is bring Names into scope. -Finally, you may wonder why filter_occs removes in-scope variables +Finally, you may wonder why filterFreeVarsToBind removes in-scope variables from bndr/body_kv_occs. How can anything be in scope? Answer: HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax ConDecls @@ -933,12 +992,13 @@ NB: we do this only at the binding site of 'tvs'. -} -bindLHsTyVarBndrs :: HsDocContext +bindLHsTyVarBndrs :: (OutputableBndrFlag flag) + => HsDocContext -> Maybe SDoc -- Just d => check for unused tvs -- d is a phrase like "in the type ..." -> Maybe a -- Just _ => an associated type decl - -> [LHsTyVarBndr GhcPs] -- User-written tyvars - -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> [LHsTyVarBndr flag GhcPs] -- User-written tyvars + -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars) bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) @@ -960,24 +1020,24 @@ bindLHsTyVarBndr :: HsDocContext -> Maybe a -- associated class - -> LHsTyVarBndr GhcPs - -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) + -> LHsTyVarBndr flag GhcPs + -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) bindLHsTyVarBndr _doc mb_assoc (L loc - (UserTyVar x + (UserTyVar x fl lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (L loc (UserTyVar x (L lv nm))) } + thing_inside (L loc (UserTyVar x fl (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) + $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name @@ -1376,8 +1436,8 @@ * * ***************************************************** -} -unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc -unexpectedTypeSigErr ty +unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc +unexpectedPatSigTypeErr ty = hang (text "Illegal type signature:" <+> quotes (ppr ty)) 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") @@ -1399,7 +1459,7 @@ inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) -warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () +warnUnusedForAll :: (OutputableBndrFlag flag) => SDoc -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ @@ -1573,9 +1633,15 @@ -- | A 'FreeKiTyVars' list that contains no duplicate variables. type FreeKiTyVarsNoDups = FreeKiTyVars +-- | Filter out any type and kind variables that are already in scope in the +-- the supplied LocalRdrEnv. Note that this includes named wildcards, which +-- look like perfectly ordinary type variables at this point. filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) +-- | Filter out any type and kind variables that are already in scope in the +-- the environment's LocalRdrEnv. Note that this includes named wildcards, +-- which look like perfectly ordinary type variables at this point. filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars filterInScopeM vars = do { rdr_env <- getLocalRdrEnv @@ -1624,7 +1690,7 @@ -- Note [Ordering of implicit variables] and -- Note [Implicit quantification in type synonyms]. extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups -extractHsTyRdrTyVarsKindVars (unLoc -> ty) = +extractHsTyRdrTyVarsKindVars (L _ ty) = case ty of HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty HsKindSig _ _ ki -> extractHsTyRdrTyVars ki @@ -1644,7 +1710,7 @@ -- However duplicates are removed -- E.g. given [k1, a:k1, b:k2] -- the function returns [k1,k2], even though k1 is bound here -extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups +extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsNoDups extractHsTyVarBndrsKVs tv_bndrs = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) @@ -1652,12 +1718,12 @@ -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -extractRdrKindSigVars (L _ resultSig) - | KindSig _ k <- resultSig = extractHsTyRdrTyVars k - | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k - | otherwise = [] +extractRdrKindSigVars (L _ resultSig) = case resultSig of + KindSig _ k -> extractHsTyRdrTyVars k + TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k + _ -> [] --- Get type/kind variables mentioned in the kind signature, preserving +-- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order and without duplicates: -- -- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] @@ -1717,13 +1783,13 @@ -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc -extractHsTvBndrs :: [LHsTyVarBndr GhcPs] +extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups -- Free in body -> FreeKiTyVarsWithDups -- Free in result extractHsTvBndrs tv_bndrs body_fvs = extract_hs_tv_bndrs tv_bndrs [] body_fvs -extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] +extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups -- Accumulator -> FreeKiTyVarsWithDups -- Free in body -> FreeKiTyVarsWithDups @@ -1731,16 +1797,17 @@ -- 'a' is bound by the forall -- 'b' is a free type variable -- 'e' is a free kind variable -extract_hs_tv_bndrs tv_bndrs acc_vars body_vars - | null tv_bndrs = body_vars ++ acc_vars - | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars +extract_hs_tv_bndrs tv_bndrs acc_vars body_vars = new_vars ++ acc_vars + where + new_vars + | null tv_bndrs = body_vars + | otherwise = filterFreeVarsToBind tv_bndr_rdrs $ bndr_vars ++ body_vars -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. -- See Note [Kind variable scoping] - where bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs -extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] +extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups -- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. @@ -1750,7 +1817,7 @@ -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty [] - [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] + [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs] extract_tv :: Located RdrName -> [Located RdrName] -> [Located RdrName] @@ -1767,5 +1834,16 @@ nubL :: Eq a => [Located a] -> [Located a] nubL = nubBy eqLocated -elemRdr :: Located RdrName -> [Located RdrName] -> Bool -elemRdr x = any (eqLocated x) +-- | Filter out any potential implicit binders that are either +-- already in scope, or are explicitly bound in the binder. +filterFreeVarsToBind :: FreeKiTyVars + -- ^ Explicitly bound here + -> FreeKiTyVarsWithDups + -- ^ Potential implicit binders + -> FreeKiTyVarsWithDups + -- ^ Final implicit binders +filterFreeVarsToBind bndrs = filterOut is_in_scope + -- Make sure to list the binder kvs before the body kvs, as mandated by + -- Note [Ordering of implicit variables] + where + is_in_scope locc = any (eqLocated locc) bndrs diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -17,7 +17,7 @@ rnSrcDecls, addTcgDUs, findSplice ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -59,7 +59,7 @@ import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session -import GHC.Utils.Misc ( debugIsOn, filterOut, lengthExceeds, partitionWith ) +import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith ) import GHC.Driver.Types ( HscEnv, hsc_dflags ) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) @@ -73,7 +73,7 @@ import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) +import Data.Maybe ( isNothing, isJust, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) import Data.Function ( on ) @@ -370,7 +370,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty -- Mark any PackageTarget style imports as coming from the current package ; let unitId = thisPackage $ hsc_dflags topEnv @@ -382,7 +382,7 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty' , fd_fe = spec } @@ -602,7 +602,7 @@ , cid_overlap_mode = oflag , cid_datafam_insts = adts }) = do { (inst_ty', inst_fvs) - <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty + <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inf_err inst_ty ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; cls <- case hsTyGetAppHead_maybe head_ty' of @@ -659,10 +659,14 @@ -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context). + where + inf_err = Just (text "Inferred type variables are not allowed") rnFamInstEqn :: HsDocContext -> AssocTyFamInfo - -> [Located RdrName] -- Kind variables from the equation's RHS + -> [Located RdrName] + -- ^ Kind variables from the equation's RHS to be implicitly bound + -- if no explicit forall. -> FamInstEqn GhcPs rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) -> RnM (FamInstEqn GhcRn rhs', FreeVars) @@ -681,21 +685,36 @@ -- Use the "...Dups" form because it's needed -- below to report unused binder on the LHS - -- Implicitly bound variables, empty if we have an explicit 'forall' according - -- to the "forall-or-nothing" rule. - ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups - | otherwise = [] - ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars - ; let bndrs = fromMaybe [] mb_bndrs - bnd_vars = map hsLTyVarLocName bndrs - payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars - -- Make sure to filter out the kind variables that were explicitly - -- bound in the type patterns. - ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars - -- all names not bound in an explicit forall - ; let all_imp_var_names = imp_var_names ++ payload_kvar_names + -- all_imp_vars represent the implicitly bound type variables. This is + -- empty if we have an explicit `forall` (see + -- Note [forall-or-nothing rule] in GHC.Rename.HsType), which means + -- ignoring: + -- + -- - pat_kity_vars_with_dups, the variables mentioned in the LHS of + -- the equation, and + -- - rhs_kvars, the kind variables mentioned in an outermost kind + -- signature on the RHS of the equation. (See + -- Note [Implicit quantification in type synonyms] in + -- GHC.Rename.HsType for why these are implicitly quantified in the + -- absence of an explicit forall). + -- + -- For example: + -- + -- @ + -- type family F a b + -- type instance forall a b c. F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [] + -- type instance F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [a, b, c] + -- @ + ; all_imp_vars <- forAllOrNothing (isJust mb_bndrs) $ + -- No need to filter out explicit binders (the 'mb_bndrs = Just + -- explicit_bndrs' case) because there must be none if we're going + -- to implicitly bind anything, per the previous comment. + nubL $ pat_kity_vars_with_dups ++ rhs_kvars + ; all_imp_var_names <- mapM (newTyVarNameRn mb_cls) all_imp_vars -- All the free vars of the family patterns -- with a sensible binding location @@ -958,10 +977,11 @@ ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; (mds', ty', fvs) <- rnLDerivStrategy DerivDeclCtx mds $ - rnHsSigWcType BindUnlessForall DerivDeclCtx ty + rnHsSigWcType DerivDeclCtx inf_err ty ; warnNoDerivStrat mds' loc ; return (DerivDecl noExtField ty' mds' overlap, fvs) } where + inf_err = Just (text "Inferred type variables are not allowed") loc = getLoc $ hsib_body $ hswc_body ty standaloneDerivErr :: SDoc @@ -1029,7 +1049,7 @@ go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside - = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> + = rnHsPatSigType bind_free_tvs doc Nothing bsig $ \ bsig' -> go vars ns $ \ vars' -> thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') @@ -1039,8 +1059,8 @@ bind_free_tvs = case tyvs of Nothing -> AlwaysBind Just _ -> NeverBind -bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] - -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) +bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr () GhcPs] + -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars) bindRuleTyVars doc in_doc (Just bndrs) thing_inside = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) @@ -1369,7 +1389,7 @@ ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v) - ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki + ; (new_ki, fvs) <- rnHsSigType doc KindLevel Nothing ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } where @@ -1401,8 +1421,8 @@ toParents :: GlobalRdrEnv -> NameSet -> NameSet toParents rdr_env ns - = nonDetFoldUniqSet add emptyNameSet ns - -- It's OK to use nonDetFoldUFM because we immediately forget the + = nonDetStrictFoldUniqSet add emptyNameSet ns + -- It's OK to use a non-deterministic fold because we immediately forget the -- ordering by creating a set where add n s = extendNameSet s (getParent rdr_env n) @@ -1768,12 +1788,14 @@ , deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs) - <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct + <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel inf_err) dct ; warnNoDerivStrat dcs' loc ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs' , deriv_clause_tys = L loc' dct' }) , fvs ) } + where + inf_err = Just (text "Inferred type variables are not allowed") rnLDerivStrategy :: forall a. HsDocContext @@ -1806,7 +1828,7 @@ AnyclassStrategy -> boring_case AnyclassStrategy NewtypeStrategy -> boring_case NewtypeStrategy ViaStrategy via_ty -> - do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + do (via_ty', fvs1) <- rnHsSigType doc TypeLevel inf_err via_ty let HsIB { hsib_ext = via_imp_tvs , hsib_body = via_body } = via_ty' (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body @@ -1815,6 +1837,8 @@ (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + inf_err = Just (text "Inferred type variables are not allowed") + boring_case :: ds -> RnM (ds, a, FreeVars) boring_case ds = do (thing, fvs) <- thing_inside @@ -2073,7 +2097,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names , con_forall = L _ explicit_forall - , con_qvars = qtvs + , con_qvars = explicit_tkvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty @@ -2082,8 +2106,7 @@ ; new_names <- mapM lookupLocatedTopBndrRn names ; mb_doc' <- rnMbLHsDoc mb_doc - ; let explicit_tkvs = hsQTvExplicit qtvs - theta = hsConDeclTheta mcxt + ; let theta = hsConDeclTheta mcxt arg_tys = hsConDeclArgTys args -- We must ensure that we extract the free tkvs in left-to-right @@ -2091,14 +2114,14 @@ -- That order governs the order the implicitly-quantified type -- variable, and hence the order needed for visible type application -- See #14808. - free_tkvs = extractHsTvBndrs explicit_tkvs $ - extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) + ; implicit_bndrs <- forAllOrNothing explicit_forall + $ extractHsTvBndrs explicit_tkvs + $ extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) - ctxt = ConDeclCtx new_names + ; let ctxt = ConDeclCtx new_names mb_ctxt = Just (inHsDocContext ctxt) - ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) - ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs -> + ; rnImplicitBndrs implicit_bndrs $ \ implicit_tkvs -> bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args @@ -2114,12 +2137,9 @@ -- See Note [GADT abstract syntax] in GHC.Hs.Decls (PrefixCon arg_tys, final_res_ty) - new_qtvs = HsQTvs { hsq_ext = implicit_tkvs - , hsq_explicit = explicit_tkvs } - ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) - ; return (decl { con_g_ext = noExtField, con_names = new_names - , con_qvars = new_qtvs, con_mb_cxt = new_cxt + ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names + , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt , con_args = args', con_res_ty = res_ty' , con_doc = mb_doc' }, all_fvs) } } diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -30,7 +30,7 @@ ImportDeclUsage ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -638,9 +638,12 @@ | otherwise = return (extendGlobalRdrEnv env gre) where - name = gre_name gre - occ = nameOccName name - dups = filter isLocalGRE (lookupGlobalRdrEnv env occ) + occ = greOccName gre + dups = filter isDupGRE (lookupGlobalRdrEnv env occ) + -- Duplicate GREs are those defined locally with the same OccName, + -- except cases where *both* GREs are DuplicateRecordFields (#17965). + isDupGRE gre' = isLocalGRE gre' + && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') {- ********************************************************************* @@ -1495,9 +1498,16 @@ | null unused = return () + -- Only one import is unused, with `SrcSpan` covering only the unused item instead of + -- the whole import statement + | Just (_, L _ imports) <- ideclHiding decl + , length unused == 1 + , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports + = addWarnAt (Reason flag) loc msg2 + -- Some imports are unused | otherwise - = addWarnAt (Reason flag) loc msg2 + = addWarnAt (Reason flag) loc msg2 where msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant @@ -1609,9 +1619,8 @@ = do { imports' <- getMinimalImports imports_w_usage ; this_mod <- getModule ; dflags <- getDynFlags - ; liftIO $ - do { h <- openFile (mkFilename dflags this_mod) WriteMode - ; printForUser dflags h neverQualify (vcat (map ppr imports')) } + ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> + printForUser dflags h neverQualify (vcat (map ppr imports')) -- The neverQualify is important. We are printing Names -- but they are in the context of an 'import' decl, and -- we never qualify things inside there @@ -1767,14 +1776,13 @@ = addErrAt (getSrcSpan (last sorted_names)) $ -- Report the error at the later location vcat [text "Multiple declarations of" <+> - quotes (ppr (nameOccName name)), + quotes (ppr (greOccName gre)), -- NB. print the OccName, not the Name, because the -- latter might not be in scope in the RdrEnv and so will -- be printed qualified. text "Declared at:" <+> vcat (map (ppr . nameSrcLoc) sorted_names)] where - name = gre_name gre sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres) diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -49,7 +49,7 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Hs import GHC.Tc.Utils.Monad @@ -218,9 +218,6 @@ ThPatQuote -> False _ -> True -rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) -rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) - newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) newPatLName name_maker rdr_name@(L loc _) = do { name <- newPatName name_maker rdr_name @@ -410,9 +407,12 @@ -- f ((Just (x :: a) :: Maybe a) -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here -- ~~~~~~~~~~~~~~~^ the same `a' then used here - = do { sig' <- rnHsSigCps sig + = do { sig' <- rnHsPatSigTypeAndThen sig ; pat' <- rnLPatAndThen mk pat ; return (SigPat x pat' sig' ) } + where + rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn) + rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx Nothing sig) rnPatAndThen mk (LitPat x lit) | HsString src s <- lit diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -12,7 +12,7 @@ , traceSplice, SpliceInfo(..) ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -40,6 +40,7 @@ import GHC.Utils.Exception import Control.Monad +import Control.Monad.Catch as MC import Data.List ( (\\) ) import Data.Maybe import Data.IORef @@ -177,7 +178,7 @@ -- XXX: this tries to disable logging of errors -- does this still do what it is intended to do -- with the changed error handling and logging? - let noop_log _ _ _ _ _ _ = return () + let noop_log _ _ _ _ _ = return () expr = "Prelude.return (Prelude.show " ++ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String" @@ -192,7 +193,7 @@ return $ Just $ cparen (prec >= myprec && needsParens txt) (text txt) else return Nothing - `gfinally` do + `MC.finally` do setSession hsc_env GHC.setSessionDynFlags dflags cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = @@ -228,7 +229,7 @@ let depthBound = 100 -- If the value is an exception, make sure we catch it and -- show the exception, rather than propagating the exception out. - e_term <- gtry $ GHC.obtainTermFromId depthBound False id + e_term <- MC.try $ GHC.obtainTermFromId depthBound False id docs_term <- case e_term of Right term -> showTerm term Left exn -> return (text "*** Exception:" <+> diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -44,7 +44,7 @@ Term(..), obtainTermFromId, obtainTermFromVal, reconstructType ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -64,6 +64,7 @@ import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) +import qualified GHC.Core.Type as Type import GHC.Types.RepType import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint @@ -108,22 +109,21 @@ import qualified Data.Map as Map import GHC.Data.StringBuffer (stringToStringBuffer) import Control.Monad +import Control.Monad.Catch as MC import Data.Array import GHC.Utils.Exception import Unsafe.Coerce ( unsafeCoerce ) import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) ) - import GHC.Tc.Utils.Env (tcGetInstEnvs) - import GHC.Tc.Utils.Instantiate (instDFunType) import GHC.Tc.Solver (solveWanteds) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Evidence import Data.Bifunctor (second) - import GHC.Tc.Solver.Monad (runTcS) +import GHC.Core.Class (classTyCon) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -291,7 +291,7 @@ setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } liftIO $ setCurrentDirectory orig_dir - gbracket set_cwd reset_cwd $ \_ -> m + MC.bracket set_cwd reset_cwd $ \_ -> m parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr @@ -1055,6 +1055,7 @@ -- Bring class and instances from unqualified modules into scope, this fixes #16793. loadUnqualIfaces hsc_env (hsc_IC hsc_env) matches <- findMatchingInstances ty + fmap catMaybes . forM matches $ uncurry checkForExistence -- Parse a type string and turn any holes into skolems @@ -1073,13 +1074,41 @@ dictName <- newName (mkDictOcc (mkVarOcc "magic")) let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin UnkSkol) Nothing - let wCs = mkSimpleWC [CtDerived - { ctev_pred = varType dict_var - , ctev_loc = loc - }] + -- Generate a wanted constraint here because at the end of constraint + -- solving, most derived constraints get thrown away, which in certain + -- cases, notably with quantified constraints makes it impossible to rule + -- out instances as invalid. (See #18071) + let wCs = mkSimpleWC [CtWanted { + ctev_pred = varType dict_var, + ctev_dest = EvVarDest dict_var, + ctev_nosh = WDeriv, + ctev_loc = loc + }] + return wCs +-- Find instances where the head unifies with the provided type +findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] +findMatchingInstances ty = do + ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs + let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local + return $ concatMap (try_cls ies) allClasses + where + {- Check that a class instance is well-kinded. + Since `:instances` only works for unary classes, we're looking for instances of kind + k -> Constraint where k is the type of the queried type. + -} + try_cls ies cls + | Just (arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) + , tcIsConstraintKind res_kind + , Type.typeKind ty `eqType` arg_kind + , (matches, _, _) <- lookupInstEnv True ies cls [ty] + = matches + | otherwise + = [] + + {- When we've found an instance that a query matches against, we still need to check that all the instance's constraints are satisfiable. checkForExistence @@ -1104,19 +1133,28 @@ -} checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) -checkForExistence res mb_inst_tys = do - (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys - - wanteds <- forM thetas getDictionaryBindings +checkForExistence clsInst mb_inst_tys = do + -- We want to force the solver to attempt to solve the constraints for clsInst. + -- Usually, this isn't a problem since there should only be a single instance + -- for a type. However, when we have overlapping instances, the solver will give up + -- since it can't decide which instance to use. To get around this restriction, instead + -- of asking the solver to solve a constraint for clsInst, we ask it to solve the + -- thetas of clsInst. + (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys + wanteds <- mapM getDictionaryBindings thetas (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds)) - let all_residual_constraints = bagToList $ wc_simple residuals - let preds = map ctPred all_residual_constraints - if all isSatisfiablePred preds && (null $ wc_impl residuals) - then return . Just $ substInstArgs tys preds res + let WC { wc_simple = simples, wc_impl = impls } = (dropDerivedWC residuals) + + let resPreds = mapBag ctPred simples + + if allBag isSatisfiablePred resPreds && solvedImplics impls + then return . Just $ substInstArgs tys (bagToList resPreds) clsInst else return Nothing where + solvedImplics :: Bag Implication -> Bool + solvedImplics impls = allBag (isSolvedStatus . ic_status) impls -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least -- one argument or for the head to be a TyVar. The reason is that we want to ensure @@ -1128,7 +1166,7 @@ Just (_, tys@(_:_)) -> all isTyVarTy tys _ -> isTyVarTy ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res))) + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) {- Create a ClsInst with instantiated arguments and constraints. @@ -1147,16 +1185,6 @@ in inst { is_dfun = (is_dfun inst) { varType = sigma }} where (dfun_tvs, _, cls, args) = instanceSig inst - --- Find instances where the head unifies with the provided type -findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] -findMatchingInstances ty = do - ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs - let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local - - concatMapM (\cls -> do - let (matches, _, _) = lookupInstEnv True ies cls [ty] - return matches) allClasses ----------------------------------------------------------------------------- -- Compile an expression, run it, and deliver the result diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -23,7 +23,7 @@ constrClosToName -- exported to use in test T4891 ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform @@ -660,7 +660,7 @@ -- as this is needed to be able to manipulate -- them properly let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty - sigma_old_ty = mkInvForAllTys old_tvs old_tau + sigma_old_ty = mkInfForAllTys old_tvs old_tau traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) term <- if null old_tvs diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -65,7 +65,7 @@ import GHC.Types.Unique.FM import GHC.Utils.Panic import GHC.Driver.Session -import GHC.Utils.Exception +import GHC.Utils.Exception as Ex import GHC.Types.Basic import GHC.Data.FastString import GHC.Utils.Misc @@ -85,6 +85,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Catch as MC (mask, onException) import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString) @@ -165,7 +166,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~ * This wiki page has an implementation overview: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter - * Note [External GHCi pointers] in compiler/ghci/GHCi.hs + * Note [External GHCi pointers] in "GHC.Runtime.Interpreter" * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs -} @@ -211,17 +212,17 @@ -- | Grab a lock on the 'IServ' and do something with it. -- Overloaded because this is used from TcM as well as IO. withIServ - :: (MonadIO m, ExceptionMonad m) + :: (ExceptionMonad m) => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a withIServ conf (IServ mIServState) action = do - gmask $ \restore -> do + MC.mask $ \restore -> do state <- liftIO $ takeMVar mIServState iserv <- case state of -- start the external iserv process if we haven't done so yet IServPending -> liftIO (spawnIServ conf) - `gonException` (liftIO $ putMVar mIServState state) + `MC.onException` (liftIO $ putMVar mIServState state) IServRunning inst -> return inst @@ -234,7 +235,7 @@ iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) -- run the inner action restore $ action iserv') - `gonException` (liftIO $ putMVar mIServState (IServRunning iserv')) + `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv')) liftIO $ putMVar mIServState (IServRunning iserv'') return a @@ -584,7 +585,7 @@ Just InternalInterp -> pure () #endif Just (ExternalInterp _ (IServ mstate)) -> - gmask $ \_restore -> modifyMVar_ mstate $ \state -> do + MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do case state of IServPending -> pure state -- already stopped IServRunning i -> do @@ -614,7 +615,7 @@ wh <- mkHandle wfd2 return (ph, rh, wh) where mkHandle :: CInt -> IO Handle - mkHandle fd = (fdToHandle fd) `onException` (c__close fd) + mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd) #else runWithPipes createProc prog opts = do diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -27,7 +27,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -72,6 +72,7 @@ import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) import Data.Maybe import Control.Concurrent.MVar +import qualified Control.Monad.Catch as MC import System.FilePath import System.Directory @@ -216,7 +217,7 @@ withExtendedLinkEnv :: (ExceptionMonad m) => DynLinker -> [(Name,ForeignHValue)] -> m a -> m a withExtendedLinkEnv dl new_env action - = gbracket (liftIO $ extendLinkEnv dl new_env) + = MC.bracket (liftIO $ extendLinkEnv dl new_env) (\_ -> reset_old_env) (\_ -> action) where @@ -233,11 +234,10 @@ -- | Display the persistent linker state. -showLinkerState :: DynLinker -> DynFlags -> IO () -showLinkerState dl dflags +showLinkerState :: DynLinker -> IO SDoc +showLinkerState dl = do pls <- readPLS dl - putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) + return $ withPprStyle defaultDumpStyle (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -420,7 +420,7 @@ | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) + $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing where platform = targetPlatform dflags @@ -1414,7 +1414,7 @@ when (wopt Opt_WarnMissedExtraSharedLib dflags) $ putLogMsg dflags (Reason Opt_WarnMissedExtraSharedLib) SevWarning - noSrcSpan (defaultUserStyle dflags)(note err) + noSrcSpan $ withPprStyle defaultUserStyle (note err) where note err = vcat $ map text [ err @@ -1715,8 +1715,7 @@ NoReason SevInteractive noSrcSpan - (defaultUserStyle dflags) - (text s) + $ withPprStyle defaultUserStyle (text s) maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -7,14 +7,14 @@ , initSettings ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Settings.Platform import GHC.Settings.Utils -import Config +import GHC.Settings.Config import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform @@ -166,7 +166,6 @@ ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" ghcWithSMP <- getBooleanSetting "Support SMP" ghcRTSWays <- getSetting "RTS ways" - leadingUnderscore <- getBooleanSetting "Leading underscore" useLibFFI <- getBooleanSetting "Use LibFFI" ghcThreaded <- getBooleanSetting "Use Threads" ghcDebugged <- getBooleanSetting "Use Debugging" @@ -237,7 +236,6 @@ , platformMisc_ghcWithSMP = ghcWithSMP , platformMisc_ghcRTSWays = ghcRTSWays , platformMisc_tablesNextToCode = tablesNextToCode - , platformMisc_leadingUnderscore = leadingUnderscore , platformMisc_libFFI = useLibFFI , platformMisc_ghcThreaded = ghcThreaded , platformMisc_ghcDebugged = ghcDebugged diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -15,7 +15,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -545,7 +545,8 @@ -- we lift @f@ newbies = abs_ids `minusDVarSet` clo_fvs' -- Lifting @f@ removes @f@ from the closure but adds all @newbies@ - cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs + cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs + -- Using a non-deterministic fold is OK here because addition is commutative. go (RhsSk body_dmd body) -- The conservative assumption would be that -- 1. Every RHS with positive growth would be called multiple times, diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -20,7 +20,7 @@ substOcc, isLifted, formerFreeVars, liftedIdsExpander ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -75,7 +75,7 @@ return () Just msg -> do putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) + $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", msg, diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -11,7 +11,7 @@ module GHC.Stg.Pipeline ( stg2stg ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -25,7 +25,7 @@ module GHC.Stg.Stats ( showStgStats ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -2,7 +2,7 @@ module GHC.Stg.Subst where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -198,7 +198,7 @@ module GHC.Stg.Unarise (unarise) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -577,17 +577,25 @@ | Just stg_arg <- IM.lookup arg_idx arg_map = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map | otherwise - = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map - - slotRubbishArg :: SlotTy -> StgArg - slotRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID - -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make - slotRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy) - slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy) - slotRubbishArg FloatSlot = StgLitArg (LitFloat 0) - slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0) + = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map in tag_arg : mkTupArgs 0 sum_slots arg_idxs + + +-- | Return a rubbish value for the given slot type. +-- +-- We use the following rubbish values: +-- * Literals: 0 or 0.0 +-- * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError` +-- +-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make +-- +ubxSumRubbishArg :: SlotTy -> StgArg +ubxSumRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy) +ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy) +ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) +ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) -------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -11,7 +11,7 @@ module GHC.StgToCmm ( codeGen ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude as Prelude diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -111,7 +111,7 @@ (_, _, fv_details) = mkVirtHeapOffsets dflags header [] -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs - (nonVoidIds args) (length args) body fv_details) + args body fv_details) ; return () } @@ -201,7 +201,7 @@ ) cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterCon (idName id) $ + = withNewTickyCounterCon (idName id) con $ buildDynCon id True cc con (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise @@ -358,8 +358,8 @@ -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere -- (b) ignore Sequel from context; use empty Sequel -- And compile the body - closureCodeBody False bndr closure_info cc (nonVoidIds args) - (length args) body fv_details + closureCodeBody False bndr closure_info cc args + body fv_details -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body @@ -436,8 +436,7 @@ -> Id -- the closure's name -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure - -> [NonVoid Id] -- incoming args to the closure - -> Int -- arity, including void args + -> [Id] -- incoming args to the closure -> CgStgExpr -> [(NonVoid Id, ByteOff)] -- the closure's free vars -> FCode () @@ -452,31 +451,32 @@ normal form, so there is no need to set up an update frame. -} -closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details - | arity == 0 -- No args i.e. thunk +-- No args i.e. thunk +closureCodeBody top_lvl bndr cl_info cc [] body fv_details = withNewTickyCounterThunk (isStaticClosure cl_info) (closureUpdReqd cl_info) (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ - \(_, node, _) -> thunkCode cl_info fv_details cc node arity body + \(_, node, _) -> thunkCode cl_info fv_details cc node body where lf_info = closureLFInfo cl_info info_tbl = mkCmmInfo cl_info bndr cc -closureCodeBody top_lvl bndr cl_info cc args arity body fv_details - = -- Note: args may be [], if all args are Void - withNewTickyCounterFun - (closureSingleEntry cl_info) - (closureName cl_info) - args $ do { +closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details + = let nv_args = nonVoidIds args + arity = length args + in + -- See Note [OneShotInfo overview] in GHC.Types.Basic. + withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) + nv_args $ do { ; let lf_info = closureLFInfo cl_info info_tbl = mkCmmInfo cl_info bndr cc -- Emit the main entry code - ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ + ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $ \(_offset, node, arg_regs) -> do -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode bndr cl_info arg_regs @@ -565,15 +565,15 @@ ----------------------------------------- thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack - -> LocalReg -> Int -> CgStgExpr -> FCode () -thunkCode cl_info fv_details _cc node arity body + -> LocalReg -> CgStgExpr -> FCode () +thunkCode cl_info fv_details _cc node body = do { dflags <- getDynFlags ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling -- Heap overflow check - ; entryHeapCheck cl_info node' arity [] $ do + ; entryHeapCheck cl_info node' 0 [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check ; tickyEnterThunk cl_info diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -48,7 +48,7 @@ -- ** Predicates -- These are really just functions on LambdaFormInfo - closureUpdReqd, closureSingleEntry, + closureUpdReqd, closureReEntrant, closureFunInfo, isToplevClosure, @@ -62,7 +62,7 @@ staticClosureNeedsLink, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -201,7 +201,6 @@ data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - OneShotInfo !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should really be in ClosureInfo) @@ -285,8 +284,7 @@ mkLFReEntrant _ _ [] _ = pprPanic "mkLFReEntrant" empty mkLFReEntrant top fvs args arg_descr - = LFReEntrant top os_info (length args) (null fvs) arg_descr - where os_info = idOneShotInfo (head args) + = LFReEntrant top (length args) (null fvs) arg_descr ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo @@ -335,7 +333,7 @@ -- the id really does point directly to the constructor | arity > 0 - = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr") + = LFReEntrant TopLevel arity True (panic "arg_descr") | otherwise = mkLFArgument id -- Not sure of exact arity @@ -384,9 +382,9 @@ lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag -- Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag dflags (LFCon con) = tagForCon dflags con -lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity -lfDynTag _ _other = 0 +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 ----------------------------------------------------------------------------- @@ -407,11 +405,11 @@ ----------------------------------------------------------------------------- lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd -lfClosureType (LFCon con) = Constr (dataConTagZ con) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" +lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) + (dataConIdentity con) +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" thunkClosureType :: StandardFormInfo -> ClosureTypeInfo thunkClosureType (SelectorThunk off) = ThunkSelector off @@ -431,7 +429,7 @@ -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument -nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _) +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) = not no_fvs -- Certainly if it has fvs we need to point to it || isNotTopLevel top -- See Note [GC recovery] -- For lex_profiling we also access the cost centre for a @@ -566,7 +564,7 @@ -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc +getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all && not (gopt Opt_SccProfilingOn dflags) @@ -811,11 +809,6 @@ lfUpdatable (LFThunk _ _ upd _ _) = upd lfUpdatable _ = False -closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd -closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True -closureSingleEntry _ = False - closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True closureReEntrant _ = False @@ -824,8 +817,8 @@ closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) -lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc) -lfFunInfo _ = Nothing +lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) +lfFunInfo _ = Nothing funTag :: DynFlags -> ClosureInfo -> DynTag funTag dflags (ClosureInfo { closureLFInfo = lf_info }) @@ -834,9 +827,9 @@ isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of - LFReEntrant TopLevel _ _ _ _ -> True - LFThunk TopLevel _ _ _ _ -> True - _other -> False + LFReEntrant TopLevel _ _ _ -> True + LFThunk TopLevel _ _ _ _ -> True + _other -> False -------------------------------------- -- Label generation diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -15,7 +15,7 @@ cgTopRhsCon, buildDynCon, bindConArgs ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -22,7 +22,7 @@ maybeLetNoEscape, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -12,7 +12,7 @@ module GHC.StgToCmm.Expr ( cgExpr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude hiding ((<*>)) @@ -902,7 +902,7 @@ -- -- Self-recursive tail calls can be optimized into a local jump in the same -- way as let-no-escape bindings (see Note [What is a non-escaping let] in --- stgSyn/CoreToStg.hs). Consider this: +-- "GHC.CoreToStg"). Consider this: -- -- foo.info: -- a = R1 // calling convention diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -30,7 +30,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude hiding ((<*>)) diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -762,8 +762,7 @@ emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped -> Int -> Bool -> FCode () emitProc mb_info lbl live blocks offset do_layout - = do { platform <- getPlatform - ; l <- newBlockId + = do { l <- newBlockId ; let blks :: CmmGraph blks = labelAGraph l blocks @@ -772,7 +771,6 @@ | otherwise = mapEmpty sinfo = StackInfo { arg_space = offset - , updfr_space = Just (initUpdFrameOff platform) , do_layout = do_layout } tinfo = TopInfo { info_tbls = infos diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -22,7 +22,7 @@ shouldInlinePrimOp ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude hiding ((<*>)) diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -82,27 +82,22 @@ tickyHeapCheck, tickyStackCheck, - tickyUnknownCall, tickyDirectCall, + tickyDirectCall, tickyPushUpdateFrame, tickyUpdateFrameOmitted, tickyEnterDynCon, - tickyEnterStaticCon, - tickyEnterViaNode, tickyEnterFun, - tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value - -- thunks only + tickyEnterThunk, tickyEnterLNE, tickyUpdateBhCaf, - tickyBlackHole, tickyUnboxedTupleReturn, tickyReturnOldCon, tickyReturnNewCon, - tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, - tickySlowCall, tickySlowCallPat, + tickySlowCall ) where import GHC.Prelude @@ -133,6 +128,7 @@ -- Turgid imports for showTypeCategory import GHC.Builtin.Names import GHC.Tc.Utils.TcType +import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Predicate @@ -150,6 +146,7 @@ = TickyFun Bool -- True <-> single entry | TickyCon + DataCon -- the allocated constructor | TickyThunk Bool -- True <-> updateable Bool -- True <-> standard thunk (AP or selector), has no entry counter @@ -193,13 +190,14 @@ withNewTickyCounterCon :: Name + -> DataCon -> FCode a -> FCode a -withNewTickyCounterCon name code = do +withNewTickyCounterCon name datacon code = do has_ctr <- thunkHasCounter False if not has_ctr then code - else withNewTickyCounter TickyCon name [] code + else withNewTickyCounter (TickyCon datacon) name [] code -- args does not include the void arguments withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a @@ -227,7 +225,7 @@ ext = case cloType of TickyFun single_entry -> parens $ hcat $ punctuate comma $ [text "fun"] ++ [text "se"|single_entry] - TickyCon -> parens (text "con") + TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon)) TickyThunk upd std -> parens $ hcat $ punctuate comma $ [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std] TickyLNE | isInternalName name -> parens (text "LNE") @@ -276,10 +274,8 @@ -- bump of name-specific ticky counter into. On the other hand, we can -- still track allocation their allocation. -tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode () -tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") +tickyEnterDynCon :: FCode () +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") tickyEnterThunk :: ClosureInfo -> FCode () tickyEnterThunk cl_info @@ -291,23 +287,13 @@ registerTickyCtrAtEntryDyn ticky_ctr_lbl bumpTickyEntryCount ticky_ctr_lbl } where - updatable = closureSingleEntry cl_info + updatable = not (closureUpdReqd cl_info) static = isStaticClosure cl_info ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" else fsLit "ENT_STATIC_THK_MANY_ctr" | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" else fsLit "ENT_DYN_THK_MANY_ctr" - -tickyEnterStdThunk :: ClosureInfo -> FCode () -tickyEnterStdThunk = tickyEnterThunk - -tickyBlackHole :: Bool{-updatable-} -> FCode () -tickyBlackHole updatable - = ifTicky (bumpTickyCounter ctr) - where - ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr") - | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr") tickyUpdateBhCaf :: ClosureInfo -> FCode () tickyUpdateBhCaf cl_info diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -38,7 +38,6 @@ addToMem, addToMemE, addToMemLblE, addToMemLbl, newStringCLit, newByteStringCLit, - blankWord, -- * Update remembered set operations whenUpdRemSetEnabled, @@ -46,7 +45,7 @@ emitUpdRemSetPushThunk, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -242,7 +241,7 @@ -- here, as we don't have liveness information. And really, we -- shouldn't be doing the workaround at this point in the pipeline, see -- Note [Register parameter passing] and the ToDo on CmmCall in --- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across +-- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across -- unsafe foreign calls in rewriteAssignments, but this is strictly -- temporary. callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph) diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -36,7 +36,7 @@ getFrameworkOpts ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -77,7 +77,7 @@ mkExtraObjToLinkIntoBinary dflags = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) + $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -155,7 +155,7 @@ -- ALL generated assembly must have this section to disable -- executable stacks. See also - -- compiler/nativeGen/AsmCodeGen.hs for another instance + -- "GHC.CmmToAsm" for another instance -- where we need to do this. if platformHasGnuNonexecStack platform then text ".section .note.GNU-stack,\"\"," diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Process where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Utils.Exception import GHC.Utils.Error @@ -282,11 +282,11 @@ case msg of BuildMsg msg -> do putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) msg + $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) - (defaultUserStyle dflags) msg + $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> log_loop chan (t-1) diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -186,7 +186,7 @@ args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - Exception.catch (do + catch (do runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env ) (\(err :: SomeException) -> do @@ -314,23 +314,10 @@ let ar = pgm_ar dflags runSomethingFiltered dflags id "Ar" ar args cwd Nothing -askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String -askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do - let ar = pgm_ar dflags - runSomethingWith dflags "Ar" ar args $ \real_args -> - readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd } - runRanlib :: DynFlags -> [Option] -> IO () runRanlib dflags args = traceToolCommand dflags "ranlib" $ do let ranlib = pgm_ranlib dflags runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing - -runMkDLL :: DynFlags -> [Option] -> IO () -runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do - let (p,args0) = pgm_dll dflags - args1 = args0 ++ args - mb_env <- getGccEnv (args0++args) - runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = traceToolCommand dflags "windres" $ do diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -13,7 +13,7 @@ -- | Handles @deriving@ clauses on @data@ declarations. module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -452,7 +452,7 @@ -- | Process the derived classes in a single @deriving@ clause. deriveClause :: TyCon -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars - -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon + -- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon" -> Maybe (LDerivStrategy GhcRn) -> [LHsSigType GhcRn] -> SDoc -> TcM [EarlyDerivSpec] diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -22,7 +22,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -36,7 +36,7 @@ mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -592,8 +592,8 @@ [ succ_enum dflags , pred_enum dflags , to_enum dflags - , enum_from dflags - , enum_from_then dflags + , enum_from dflags -- [0 ..] + , enum_from_then dflags -- [0, 1 ..] , from_enum dflags ] aux_binds = listToBag $ map DerivAuxBind diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -55,7 +55,7 @@ import Data.List (zip4, partition) import Data.Maybe (isJust) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ************************************************************************ diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -14,7 +14,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -13,7 +13,7 @@ solverDepthErrorTcS ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -285,8 +285,8 @@ important doc = mempty { report_important = [doc] } -- | Put a doc into the relevant bindings block. -relevant_bindings :: SDoc -> Report -relevant_bindings doc = mempty { report_relevant_bindings = [doc] } +mk_relevant_bindings :: SDoc -> Report +mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] } -- | Put a doc into the valid hole fits block. valid_hole_fits :: SDoc -> Report @@ -524,16 +524,29 @@ -} reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics }) +reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics + , wc_holes = holes }) = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt)]) - ; traceTc "rw2" (ppr tidy_cts) + , text "Suppress =" <+> ppr (cec_suppress ctxt) + , text "tidy_cts =" <+> ppr tidy_cts + , text "tidy_holes = " <+> ppr tidy_holes ]) - -- First deal with things that are utterly wrong + -- First, deal with any out-of-scope errors: + ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes + -- don't suppress out-of-scope errors + ctxt_for_scope_errs = ctxt { cec_suppress = False } + ; (_, no_out_of_scope) <- askNoErrs $ + reportHoles tidy_cts ctxt_for_scope_errs out_of_scope + + -- Next, deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) -- or Int ~ t a (AppTy on one side) -- These /ones/ are not suppressed by the incoming context - ; let ctxt_for_insols = ctxt { cec_suppress = False } + -- (but will be by out-of-scope errors) + ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } + ; reportHoles tidy_cts ctxt_for_insols other_holes + -- holes never suppress + ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts -- Now all the other constraints. We suppress errors here if @@ -554,7 +567,8 @@ -- if there's a *given* insoluble here (= inaccessible code) where env = cec_tidy ctxt - tidy_cts = bagToList (mapBag (tidyCt env) simples) + tidy_cts = bagToList (mapBag (tidyCt env) simples) + tidy_holes = bagToList (mapBag (tidyHole env) holes) -- report1: ones that should *not* be suppressed by -- an insoluble somewhere else in the tree @@ -562,9 +576,7 @@ -- (see GHC.Tc.Utils.insolubleCt) is caught here, otherwise -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later - report1 = [ ("Out of scope", unblocked is_out_of_scope, True, mkHoleReporter tidy_cts) - , ("Holes", unblocked is_hole, False, mkHoleReporter tidy_cts) - , ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) + report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) , given_eq_spec , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) @@ -593,8 +605,7 @@ unblocked checker ct pred = checker ct pred -- rigid_nom_eq, rigid_nom_tv_eq, - is_hole, is_dict, - is_equality, is_ip, is_irred :: Ct -> Pred -> Bool + is_dict, is_equality, is_ip, is_irred :: Ct -> Pred -> Bool is_given_eq ct pred | EqPred {} <- pred = arisesFromGivens ct @@ -617,9 +628,6 @@ non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) non_tv_eq _ _ = False - is_out_of_scope ct _ = isOutOfScopeCt ct - is_hole ct _ = isHoleCt ct - is_user_type_error ct _ = isUserTypeErrorCt ct is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 @@ -705,12 +713,12 @@ | eq_lhs_type ct1 ct2 = True | otherwise = False -mkHoleReporter :: [Ct] -> Reporter --- Reports errors one at a time -mkHoleReporter tidy_simples ctxt - = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct - ; maybeReportHoleError ctxt ct err - ; maybeAddDeferredHoleBinding ctxt err ct } +reportHoles :: [Ct] -- other (tidied) constraints + -> ReportErrCtxt -> [Hole] -> TcM () +reportHoles tidy_cts ctxt + = mapM_ $ \hole -> do { err <- mkHoleError tidy_cts ctxt hole + ; maybeReportHoleError ctxt hole err + ; maybeAddDeferredHoleBinding ctxt err hole } mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt @@ -742,7 +750,7 @@ inaccessible_msg = hang (text "Inaccessible code in") 2 (ppr (ic_info implic)) report = important inaccessible_msg `mappend` - relevant_bindings binds_msg + mk_relevant_bindings binds_msg ; err <- mkEqErr_help dflags ctxt report ct' Nothing ty1 ty2 @@ -843,15 +851,27 @@ ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () +maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg -> TcM () +maybeReportHoleError ctxt hole err + | isOutOfScopeHole hole + -- Always report an error for out-of-scope variables + -- Unless -fdefer-out-of-scope-variables is on, + -- in which case the messages are discarded. + -- See #12170, #12406 + = -- If deferring, report a warning only if -Wout-of-scope-variables is on + case cec_out_of_scope_holes ctxt of + HoleError -> reportError err + HoleWarn -> + reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err + HoleDefer -> return () + -- Unlike maybeReportError, these "hole" errors are -- /not/ suppressed by cec_suppress. We want to see them! -maybeReportHoleError ctxt ct err +maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err -- When -XPartialTypeSignatures is on, warnings (instead of errors) are -- generated for holes in partial type signatures. -- Unless -fwarn-partial-type-signatures is not on, -- in which case the messages are discarded. - | isTypeHoleCt ct = -- For partial type signatures, generate warnings only, and do that -- only if -fwarn-partial-type-signatures is on case cec_type_holes ctxt of @@ -859,22 +879,12 @@ HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err HoleDefer -> return () - -- Always report an error for out-of-scope variables - -- Unless -fdefer-out-of-scope-variables is on, - -- in which case the messages are discarded. - -- See #12170, #12406 - | isOutOfScopeCt ct - = -- If deferring, report a warning only if -Wout-of-scope-variables is on - case cec_out_of_scope_holes ctxt of - HoleError -> reportError err - HoleWarn -> - reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err - HoleDefer -> return () - +maybeReportHoleError ctxt hole@(Hole { hole_sort = ExprHole _ }) err -- Otherwise this is a typed hole in an expression, - -- but not for an out-of-scope variable - | otherwise + -- but not for an out-of-scope variable (because that goes through a + -- different function) = -- If deferring, report a warning only if -Wtyped-holes is on + ASSERT( not (isOutOfScopeHole hole) ) case cec_expr_holes ctxt of HoleError -> reportError err HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err @@ -899,10 +909,7 @@ , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct -- Only add deferred bindings for Wanted constraints = do { dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - err_tm = evDelayedError pred err_fs + ; let err_tm = mkErrorTerm dflags pred err ev_binds_var = cec_binds ctxt ; case dest of @@ -917,12 +924,28 @@ | otherwise -- Do not set any evidence for Given/Derived = return () -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -maybeAddDeferredHoleBinding ctxt err ct - | isExprHoleCt ct - = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions - | otherwise -- not for holes in partial type signatures +mkErrorTerm :: DynFlags -> Type -- of the error term + -> ErrMsg -> EvTerm +mkErrorTerm dflags ty err = evDelayedError ty err_fs + where + err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" +maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Hole -> TcM () +maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole ev_id }) +-- Only add bindings for holes in expressions +-- not for holes in partial type signatures +-- cf. addDeferredBinding + | deferringAnyBindings ctxt + = do { dflags <- getDynFlags + ; let err_tm = mkErrorTerm dflags (idType ev_id) err + -- NB: idType ev_id, not hole_ty. hole_ty might be rewritten. + -- See Note [Holes] in GHC.Tc.Types.Constraint + ; addTcEvBind (cec_binds ctxt) $ mkWantedEvBind ev_id err_tm } + | otherwise = return () +maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole }) + = return () tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True @@ -961,7 +984,6 @@ where (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts - pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message -- We've done special processing for TypeEq, KindEq, Given @@ -1104,15 +1126,16 @@ ; let orig = ctOrigin ct1 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } + important msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts ---------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) - | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound - -- Suggest possible in-scope variables in the message +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM ErrMsg +mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ + , hole_ty = hole_ty + , hole_loc = ct_loc }) + | isOutOfScopeHole hole = do { dflags <- getDynFlags ; rdr_env <- getGlobalRdrEnv ; imp_info <- getImports @@ -1122,48 +1145,52 @@ errDoc [out_of_scope_msg] [] [unknownNameSuggestions dflags hpt curr_mod rdr_env (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } + where + herald | isDataOcc occ = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" - | otherwise -- Explicit holes, like "_" or "_f" - = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct + out_of_scope_msg -- Print v :: ty only if the type has structure + | boring_type = hang herald 2 (ppr occ) + | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) + + lcl_env = ctLocEnv ct_loc + boring_type = isTyVarTy hole_ty + + -- general case: not an out-of-scope error +mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ + , hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { (ctxt, binds_msg) + <- relevant_bindings False ctxt lcl_env (tyCoVarsOfType hole_ty) -- The 'False' means "don't filter the bindings"; see Trac #8191 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints ; let constraints_msg - | isExprHoleCt ct, show_hole_constraints + | ExprHole _ <- sort, show_hole_constraints = givenConstraintsMsg ctxt | otherwise = empty ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples ct + then validHoleFits ctxt tidy_simples hole else return (ctxt, empty) - ; mkErrorMsgFromCt ctxt ct $ + ; mkErrorReport ctxt lcl_env $ important hole_msg `mappend` - relevant_bindings (binds_msg $$ constraints_msg) `mappend` + mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` valid_hole_fits sub_msg } where - ct_loc = ctLoc ct lcl_env = ctLocEnv ct_loc - hole_ty = ctEvPred (ctEvidence ct) hole_kind = tcTypeKind hole_ty tyvars = tyCoVarsOfTypeList hole_ty - boring_type = isTyVarTy hole_ty - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 pp_with_type - - pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - hole_msg = case hole_sort of - ExprHole -> vcat [ hang (text "Found hole:") - 2 pp_with_type - , tyvars_msg, expr_hole_hint ] + hole_msg = case sort of + ExprHole _ -> vcat [ hang (text "Found hole:") + 2 (pp_occ_with_type occ hole_ty) + , tyvars_msg, expr_hole_hint ] TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) 2 (text "standing for" <+> quotes pp_hole_type_with_kind) , tyvars_msg, type_hole_hint ] @@ -1207,21 +1234,22 @@ = ppWhenOption sdocPrintExplicitCoercions $ quotes (ppr tv) <+> text "is a coercion variable" -mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct) +pp_occ_with_type :: OccName -> Type -> SDoc +pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) -- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module -- imports validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the -- implications and the tidy environment -> [Ct] -- Unsolved simple constraints - -> Ct -- The hole constraint. + -> Hole -- The hole -> TcM (ReportErrCtxt, SDoc) -- We return the new context -- with a possibly updated -- tidy environment, and -- the message. validHoleFits ctxt@(CEC {cec_encl = implics - , cec_tidy = lcl_env}) simps ct - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct + , cec_tidy = lcl_env}) simps hole + = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole ; return (ctxt {cec_tidy = tidy_env}, msg) } -- See Note [Constraints include ...] @@ -1255,7 +1283,7 @@ = couldNotDeduce givens (preds, orig) ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } + important msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1337,7 +1365,7 @@ ; dflags <- getDynFlags ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going) ; let report = mconcat [important wanted_msg, important coercible_msg, - relevant_bindings binds_msg] + mk_relevant_bindings binds_msg] ; if keep_going then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 else mkErrorMsgFromCt ctxt ct report } @@ -1513,7 +1541,7 @@ filter isTyVar $ fvVarList $ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = relevant_bindings $ + extra3 = mk_relevant_bindings $ ppWhen (not (null interesting_tyvars)) $ hang (text "Type variable kinds:") 2 $ vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) @@ -2819,27 +2847,45 @@ -> TcM (ReportErrCtxt, SDoc, Ct) -- Also returns the zonked and tidied CtOrigin of the constraint relevantBindings want_filtering ctxt ct - = do { dflags <- getDynFlags + = do { traceTc "relevantBindings" (ppr ct) ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs -- For *kind* errors, report the relevant bindings of the -- enclosing *type* equality, because that's more useful for the programmer - extra_tvs = case tidy_orig of + ; let extra_tvs = case tidy_orig of KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ t1 : maybeToList m_t2 _ -> emptyVarSet - ; traceTc "relevantBindings" $ - vcat [ ppr ct - , pprCtOrigin (ctLocOrigin loc) - , ppr ct_tvs + ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs + + -- Put a zonked, tidied CtOrigin into the Ct + loc' = setCtLocOrigin loc tidy_orig + ct' = setCtLoc ct loc' + ctxt1 = ctxt { cec_tidy = env1 } + + ; (ctxt2, doc) <- relevant_bindings want_filtering ctxt1 lcl_env ct_fvs + ; return (ctxt2, doc, ct') } + where + loc = ctLoc ct + lcl_env = ctLocEnv loc + +-- slightly more general version, to work also with holes +relevant_bindings :: Bool + -> ReportErrCtxt + -> TcLclEnv + -> TyCoVarSet + -> TcM (ReportErrCtxt, SDoc) +relevant_bindings want_filtering ctxt lcl_env ct_tvs + = do { dflags <- getDynFlags + ; traceTc "relevant_bindings" $ + vcat [ ppr ct_tvs , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) | TcIdBndr id _ <- tcl_bndrs lcl_env ] , pprWithCommas id [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] ; (tidy_env', docs, discards) - <- go dflags env1 ct_tvs (maxRelevantBinds dflags) + <- go dflags (cec_tidy ctxt) (maxRelevantBinds dflags) emptyVarSet [] False (removeBindingShadowing $ tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first, @@ -2849,17 +2895,10 @@ hang (text "Relevant bindings include") 2 (vcat docs $$ ppWhen discards discardMsg) - -- Put a zonked, tidied CtOrigin into the Ct - loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' ctxt' = ctxt { cec_tidy = tidy_env' } - ; return (ctxt', doc, ct') } + ; return (ctxt', doc) } where - ev = ctEvidence ct - loc = ctEvLoc ev - lcl_env = ctLocEnv loc - run_out :: Maybe Int -> Bool run_out Nothing = False run_out (Just n) = n <= 0 @@ -2868,14 +2907,14 @@ dec_max = fmap (\n -> n - 1) - go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] + go :: DynFlags -> TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool -- True <=> some filtered out due to lack of fuel -> [TcBinder] -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out -- because of lack of fuel - go _ tidy_env _ _ _ docs discards [] + go _ tidy_env _ _ docs discards [] = return (tidy_env, reverse docs, discards) - go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + go dflags tidy_env n_left tvs_seen docs discards (tc_bndr : tc_bndrs) = case tc_bndr of TcTvBndr {} -> discard_it TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl @@ -2891,7 +2930,7 @@ Nothing -> discard_it -- No info; discard } where - discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs + discard_it = go dflags tidy_env n_left tvs_seen docs discards tc_bndrs go2 id_name id_type top_lvl = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type @@ -2916,12 +2955,12 @@ else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions already-seen type variables, so discard it - then go dflags tidy_env ct_tvs n_left tvs_seen docs + then go dflags tidy_env n_left tvs_seen docs True -- Record that we have now discarded something tc_bndrs -- Keep this binding, decrement fuel - else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen + else go dflags tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -2,17 +2,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Tc.Errors.Hole - ( findValidHoleFits, tcFilterHoleFits - , tcCheckHoleFit, tcSubsumes - , withoutUnification - , fromPureHFPlugin - -- Re-exports for convenience - , hfIsLcl - , pprHoleFit, debugHoleFitDispConfig + ( findValidHoleFits -- Re-exported from GHC.Tc.Errors.Hole.FitTypes - , TypedHole (..), HoleFit (..), HoleFitCandidate (..) - , CandPlugin, FitPlugin , HoleFitPlugin (..), HoleFitPluginR (..) ) where @@ -121,7 +113,7 @@ Valid hole fits are found by checking top level identifiers and local bindings in scope for whether their type can be instantiated to the the type of the hole. Additionally, we also need to check whether all relevant constraints are solved -by choosing an identifier of that type as well, see Note [Relevant Constraints] +by choosing an identifier of that type as well, see Note [Relevant constraints] Since checking for subsumption results in the side-effect of type variables being unified by the simplifier, we need to take care to restore them after @@ -143,9 +135,13 @@ If -XTypeApplications is enabled, this can even be copied verbatim as a replacement for the hole. - -Note [Nested implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Checking hole fits] +~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a hole of type hole_ty, we want to know whether a variable +of type ty is a valid fit for the whole. This is a subsumption check: +we wish to know whether ty <: hole_ty. But, of course, the check +must take into account any givens and relevant constraints. +(See also Note [Relevant constraints]). For the simplifier to be able to use any givens present in the enclosing implications to solve relevant constraints, we nest the wanted subsumption @@ -156,10 +152,7 @@ f :: Show a => a -> String f x = show _ -The hole will result in the hole constraint: - - [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)) - +Suppose the hole is assigned type a0_a1pd[tau:2]. Here the nested implications are just one level deep, namely: [Implic { @@ -170,36 +163,25 @@ Given = $dShow_a1pc :: Show a_a1pa[sk:2] Wanted = WC {wc_simple = - [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_)) - [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))} + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))} Binds = EvBindsVar Needed inner = [] Needed outer = [] the type signature for: f :: forall a. Show a => a -> String }] -As we can see, the givens say that the information about the skolem -`a_a1pa[sk:2]` fulfills the Show constraint. - -The simples are: - - [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)] - -I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must -fulfill `Show a0_a1pd[tau:2])`. - -So when we run the check, we need to make sure that the - - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical) +As we can see, the givens say that the skolem +`a_a1pa[sk:2]` fulfills the Show constraint, and that we must prove +the [W] Show a0_a1pd[tau:2] constraint -- that is, whatever fills the +hole must have a Show instance. -Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits -the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the -meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted -constraints needed by tcSubType_NC and the relevant constraints (see -Note [Relevant Constraints] for more details) in the nested implications, we -can pass the information in the givens along to the simplifier. For our example, -we end up needing to check whether the following constraints are soluble. +When we now check whether `x :: a_a1pa[sk:2]` fits the hole in +`tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type +variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints +needed by tcSubType_NC and the relevant constraints (see Note [Relevant +Constraints] for more details) in the nested implications, we can pass the +information in the givens along to the simplifier. For our example, we end up +needing to check whether the following constraints are soluble. WC {wc_impl = Implic { @@ -223,10 +205,12 @@ To avoid side-effects on the nested implications, we create a new EvBindsVar so that any changes to the ev binds during a check remains localised to that check. - +In addition, we call withoutUnification to reset any unified metavariables; this +call is actually done outside tcCheckHoleFit so that the results can be formatted +for the user before resetting variables. Note [Valid refinement hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the `-frefinement-level-hole-fits=N` flag is given, we additionally look for "valid refinement hole fits"", i.e. valid hole fits with up to N additional holes in them. @@ -337,10 +321,8 @@ be applied to an expression of type `a -> Free f b` in order to match. If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. - -Note [Relevant Constraints] -~~~~~~~~~~~~~~~~~~~ - +Note [Relevant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ As highlighted by #14273, we need to check any relevant constraints as well as checking for subsumption. Relevant constraints are the simple constraints whose free unification variables are mentioned in the type of the hole. @@ -351,10 +333,9 @@ f :: String f = show _ -Where the simples will be : +Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: - [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)] + [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical) However, when there are multiple holes, we need to be more careful. As an example, Let's take a look at the following code: @@ -362,29 +343,24 @@ f :: Show a => a -> String f x = show (_b (show _a)) -Here there are two holes, `_a` and `_b`, and the simple constraints passed to +Here there are two holes, `_a` and `_b`. Suppose _a :: a0_a1pd[tau:2] and +_b :: a1_a1po[tau:2]. Then, the simple constraints passed to findValidHoleFits are: - [[WD] _a_a1pi {0}:: String - -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)), - [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), + [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] - -Here we have the two hole constraints for `_a` and `_b`, but also additional -constraints that these holes must fulfill. When we are looking for a match for -the hole `_a`, we filter the simple constraints to the "Relevant constraints", -by throwing out all hole constraints and any constraints which do not mention -a variable mentioned in the type of the hole. For hole `_a`, we will then -only require that the `$dShow_a1pp` constraint is solved, since that is -the only non-hole constraint that mentions any free type variables mentioned in -the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the -hole `_b` we only require that the `$dShow_a1pe` constraint is solved. +When we are looking for a match for the hole `_a`, we filter the simple +constraints to the "Relevant constraints", by throwing out any constraints +which do not mention a variable mentioned in the type of the hole. For hole +`_a`, we will then only require that the `$dShow_a1pe` constraint is solved, +since that is the only constraint that mentions any free type variables +mentioned in the hole constraint for `_a`, namely `a_a1pd[tau:2]`, and +similarly for the hole `_b` we only require that the `$dShow_a1pe` constraint +is solved. Note [Leaking errors] -~~~~~~~~~~~~~~~~~~~ - +~~~~~~~~~~~~~~~~~~~~~ When considering candidates, GHC believes that we're checking for validity in actual source. However, As evidenced by #15321, #15007 and #15202, this can cause bewildering error messages. The solution here is simple: if a candidate @@ -393,17 +369,12 @@ -} - data HoleFitDispConfig = HFDC { showWrap :: Bool , showWrapVars :: Bool , showType :: Bool , showProv :: Bool , showMatches :: Bool } -debugHoleFitDispConfig :: HoleFitDispConfig -debugHoleFitDispConfig = HFDC True True True False False - - -- We read the various -no-show-*-of-hole-fits flags -- and set the display config accordingly. getHoleFitDispConfig :: TcM HoleFitDispConfig @@ -470,10 +441,12 @@ where name = getName hfCand tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap where pprArg b arg = case binderArgFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty + -- See Note [Explicit Case Statement for Specificity] + (Invisible spec) -> case spec of + SpecifiedSpec -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + InferredSpec -> empty Required -> pprPanic "pprHoleFit: bad Required" (ppr b <+> ppr arg) tyAppVars = sep $ punctuate comma $ @@ -516,13 +489,12 @@ GreHFCand gre -> pprNameProvenance gre _ -> text "bound at" <+> ppr (getSrcLoc name) -getLocalBindings :: TidyEnv -> Ct -> TcM [Id] -getLocalBindings tidy_orig ct - = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc) +getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] +getLocalBindings tidy_orig ct_loc + = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } where - loc = ctEvLoc (ctEvidence ct) - lcl_env = ctLocEnv loc + lcl_env = ctLocEnv ct_loc go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] go _ sofar [] = return (reverse sofar) @@ -542,11 +514,13 @@ -> [Ct] -- ^ The unsolved simple constraints in the implication for -- the hole. - -> Ct -- ^ The hole constraint itself + -> Hole -> TcM (TidyEnv, SDoc) -findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct = +findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ + , hole_loc = ct_loc + , hole_ty = hole_ty }) = do { rdr_env <- getGlobalRdrEnv - ; lclBinds <- getLocalBindings tidy_env ct + ; lclBinds <- getLocalBindings tidy_env ct_loc ; maxVSubs <- maxValidHoleFits <$> getDynFlags ; hfdc <- getHoleFitDispConfig ; sortingAlg <- getSortingAlg @@ -554,7 +528,9 @@ ; hfPlugs <- tcg_hf_plugins <$> getGblEnv ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs refLevel = refLevelHoleFits dflags - hole = TyH (listToBag relevantCts) implics (Just ct) + hole = TypedHole { th_relevant_cts = listToBag relevantCts + , th_implics = implics + , th_hole = Just h } (candidatePlugins, fitPlugins) = unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs ; traceTc "findingValidHoleFitsFor { " $ ppr hole @@ -625,11 +601,9 @@ where -- We extract the type, the tcLevel and the types free variables -- from from the constraint. - hole_ty :: TcPredType - hole_ty = ctPred ct hole_fvs :: FV hole_fvs = tyCoFVsOfType hole_ty - hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct + hole_lvl = ctLocLevel ct_loc -- BuiltInSyntax names like (:) and [] builtIns :: [Name] @@ -668,7 +642,7 @@ <*> sortByGraph (sort gblFits) where (lclFits, gblFits) = span hfIsLcl subs - -- See Note [Relevant Constraints] + -- See Note [Relevant constraints] relevantCts :: [Ct] relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then [] else filter isRelevant simples @@ -676,15 +650,13 @@ ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred hole_fv_set = fvVarSet hole_fvs anyFVMentioned :: Ct -> Bool - anyFVMentioned ct = not $ isEmptyVarSet $ - ctFreeVarSet ct `intersectVarSet` hole_fv_set + anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set -- We filter out those constraints that have no variables (since -- they won't be solved by finding a type for the type variable -- representing the hole) and also other holes, since we're not -- trying to find hole fits for many holes at once. isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) && anyFVMentioned ct - && not (isHoleCt ct) -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output. @@ -761,7 +733,7 @@ -- ^ We return whether or not we stopped due to hitting the limit -- and the fits we found. tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 -tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates = +tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = do { traceTc "checkingFitsFor {" $ ppr hole_ty ; (discards, subs) <- go [] emptyVarSet limit ht candidates ; traceTc "checkingFitsFor }" empty @@ -895,8 +867,7 @@ else return Nothing } else return Nothing } where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty - hole = TyH tyHRelevantCts tyHImplics Nothing - + hole = typed_hole { th_hole = Nothing } subsDiscardMsg :: SDoc subsDiscardMsg = @@ -925,7 +896,8 @@ -- Reset any mutated free variables ; mapM_ restore flexis ; return result } - where restore = flip writeTcRef Flexi . metaTyVarRef + where restore tv = do { traceTc "withoutUnification: restore flexi" (ppr tv) + ; writeTcRef (metaTyVarRef tv) Flexi } fuvs = fvVarList free_vars -- | Reports whether first type (ty_a) subsumes the second type (ty_b), @@ -933,14 +905,14 @@ -- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b - where dummyHole = TyH emptyBag [] Nothing + where dummyHole = TypedHole { th_relevant_cts = emptyBag + , th_implics = [] + , th_hole = Nothing } -- | A tcSubsumes which takes into account relevant constraints, to fix trac -- #14273. This makes sure that when checking whether a type fits the hole, -- the type has to be subsumed by type of the hole as well as fulfill all -- constraints on the type of the hole. --- Note: The simplifier may perform unification, so make sure to restore any --- free type variables to avoid side-effects. tcCheckHoleFit :: TypedHole -- ^ The hole to check against -> TcSigmaType -- ^ The type to check against (possibly modified, e.g. refined) @@ -949,56 +921,48 @@ -- ^ Whether it was a match, and the wrapper from hole_ty to ty. tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty = return (True, idHsWrapper) -tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ +tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $ do { -- We wrap the subtype constraint in the implications to pass along the -- givens, and so we must ensure that any nested implications and skolems -- end up with the correct level. The implications are ordered so that -- the innermost (the one with the highest level) is first, so it -- suffices to get the level of the first one (or the current level, if -- there are no implications involved). - innermost_lvl <- case tyHImplics of + innermost_lvl <- case th_implics of [] -> getTcLevel -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) - ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ - tcSubType_NC ExprSigCtxt ty hole_ty + ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ + tcSubType_NC ExprSigCtxt ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted - ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts - then traceTc "}" empty >> return (True, wrp) + ; if isEmptyWC wanted && isEmptyBag th_relevant_cts + then do { traceTc "}" empty + ; return (True, wrap) } else do { fresh_binds <- newTcEvBinds -- The relevant constraints may contain HoleDests, so we must -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts + ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts -- We wrap the WC in the nested implications, see - -- Note [Nested Implications] - ; let outermost_first = reverse tyHImplics - setWC = setWCAndBinds fresh_binds + -- Note [Checking hole fits] + ; let outermost_first = reverse th_implics -- We add the cloned relevants to the wanteds generated by - -- the call to tcSubType_NC, see Note [Relevant Constraints] + -- the call to tcSubType_NC, see Note [Relevant constraints] -- There's no need to clone the wanteds, because they are -- freshly generated by `tcSubtype_NC`. w_rel_cts = addSimples wanted cloned_relevants - w_givens = foldr setWC w_rel_cts outermost_first - ; traceTc "w_givens are: " $ ppr w_givens - ; rem <- runTcSDeriveds $ simpl_top w_givens + final_wc = foldr (setWCAndBinds fresh_binds) w_rel_cts outermost_first + ; traceTc "final_wc is: " $ ppr final_wc + ; rem <- runTcSDeriveds $ simpl_top final_wc -- We don't want any insoluble or simple constraints left, but -- solved implications are ok (and necessary for e.g. undefined) ; traceTc "rems was:" $ ppr rem ; traceTc "}" empty - ; return (isSolvedWC rem, wrp) } } + ; return (isSolvedWC rem, wrap) } } where setWCAndBinds :: EvBindsVar -- Fresh ev binds var. -> Implication -- The implication to put WC in. -> WantedConstraints -- The WC constraints to put implic. -> WantedConstraints -- The new constraints. setWCAndBinds binds imp wc - = WC { wc_simple = emptyBag - , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } } - --- | Maps a plugin that needs no state to one with an empty one. -fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR -fromPureHFPlugin plug = - HoleFitPluginR { hfPluginInit = newTcRef () - , hfPluginRun = const plug - , hfPluginStop = const $ return () } + = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot --- a/compiler/GHC/Tc/Errors/Hole.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -5,9 +5,9 @@ module GHC.Tc.Errors.Hole where import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Constraint ( Ct, Implication ) +import GHC.Tc.Types.Constraint ( Ct, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv ) -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct +findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole -> TcM (TidyEnv, SDoc) diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -307,7 +307,7 @@ = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' - ; let e_ty = mkInvForAllTy alphaTyVar $ + ; let e_ty = mkInfForAllTy alphaTyVar $ mkVisFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcCheckExpr expr e_ty diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -73,7 +73,7 @@ import Control.Monad import Data.Foldable (find) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ************************************************************************ @@ -907,7 +907,7 @@ ; (binders, theta') <- chooseInferredQuantifiers inferred_theta (tyCoVarsOfType mono_ty') qtvs mb_sig_inst - ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') + ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' , ppr inferred_poly_ty]) @@ -926,13 +926,13 @@ -> TcTyVarSet -- tvs free in tau type -> [TcTyVar] -- inferred quantified tvs -> Maybe TcIdSigInst - -> TcM ([TyVarBinder], TcThetaType) + -> TcM ([InvisTVBinder], TcThetaType) chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing = -- No type signature (partial or complete) for this binder, do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) -- Include kind variables! #7916 my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkTyVarBinder Inferred tv + binders = [ mkTyVarBinder InferredSpec tv | tv <- qtvs , tv `elemVarSet` free_tvs ] ; return (binders, my_theta) } @@ -943,7 +943,8 @@ , sig_inst_theta = annotated_theta , sig_inst_skols = annotated_tvs })) = -- Choose quantifiers for a partial type signature - do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs + do { psig_qtvbndr_prs <- zonkTyVarTyVarPairs annotated_tvs + ; let psig_qtv_prs = mapSnd binderVar psig_qtvbndr_prs -- Check whether the quantified variables of the -- partial signature have been unified together @@ -957,7 +958,8 @@ ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs , not (tv `elem` qtvs) ] - ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) + ; let psig_qtvbndrs = map snd psig_qtvbndr_prs + psig_qtvs = mkVarSet (map snd psig_qtv_prs) ; annotated_theta <- zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx @@ -966,8 +968,9 @@ final_qtvs = [ mkTyVarBinder vis tv | tv <- qtvs -- Pulling from qtvs maintains original order , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] + , let vis = case lookupVarBndr tv psig_qtvbndrs of + Just spec -> spec + Nothing -> InferredSpec ] ; return (final_qtvs, my_theta) } where @@ -1447,7 +1450,7 @@ tcExtendTyVarEnvFromSig sig_inst thing_inside | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst = tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv skol_prs $ + tcExtendNameTyVarEnv (mapSnd binderVar skol_prs) $ thing_inside tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -28,7 +28,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -36,7 +36,6 @@ import GHC.Builtin.Names.TH( liftStringName, liftName ) import GHC.Hs -import GHC.Tc.Types.Constraint ( HoleSort(..) ) import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify @@ -981,12 +980,9 @@ res_ty = do addModFinalizersWithLclEnv mod_finalizers tcExpr expr res_ty -tcExpr (HsSpliceE _ splice) res_ty - = tcSpliceExpr splice res_ty -tcExpr e@(HsBracket _ brack) res_ty - = tcTypedBracket e brack res_ty -tcExpr e@(HsRnBracketOut _ brack ps) res_ty - = tcUntypedBracket e brack ps res_ty +tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty +tcExpr e@(HsBracket _ brack) res_ty = tcTypedBracket e brack res_ty +tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty {- ************************************************************************ @@ -1219,7 +1215,11 @@ = do { (fun, args, app_res_ty) <- tcInferApp expr ; if isTagToEnum fun then tcTagToEnum expr fun args app_res_ty res_ty - else -- The wildly common case + -- Done here because we have res_ty, + -- whereas tcInferApp does not + else + + -- The wildly common case do { let expr' = applyHsArgs fun args ; addFunResCtxt True fun app_res_ty res_ty $ tcWrapResult expr expr' app_res_ty res_ty } } @@ -1232,10 +1232,10 @@ -- Also used by Module.tcRnExpr to implement GHCi :type tcInferApp expr | -- Gruesome special case for ambiguous record selectors - HsRecFld _ fld_lbl <- fun - , Ambiguous _ lbl <- fld_lbl -- Still ambiguous + HsRecFld _ fld_lbl <- fun + , Ambiguous _ lbl <- fld_lbl -- Still ambiguous , HsEValArg _ (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first - , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates + , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) @@ -1259,11 +1259,7 @@ -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType) tcInferApp_finish rn_fun tc_fun fun_sigma rn_args - = do { traceTc "tcInferApp_finish" $ - vcat [ ppr rn_fun <+> dcolon <+> ppr fun_sigma, ppr rn_args ] - - ; (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args - + = do { (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args ; return (tc_fun, tc_args, actual_res_ty) } mk_op_msg :: LHsExpr GhcRn -> SDoc @@ -1408,22 +1404,21 @@ Then the renamer will make (HsUnboundVar "wurble) for 'wurble', and the typechecker will typecheck it with tcUnboundId, giving it -a type 'alpha', and emitting a deferred CHoleCan constraint, to -be reported later. +a type 'alpha', and emitting a deferred Hole, to be reported later. But then comes the visible type application. If we do nothing, we'll generate an immediate failure (in tc_app_err), saying that a function of type 'alpha' can't be applied to Bool. That's insane! And indeed users complain bitterly (#13834, #17150.) -The right error is the CHoleCan, which has /already/ been emitted by +The right error is the Hole, which has /already/ been emitted by tcUnboundId. It later reports 'wurble' as out of scope, and tries to give its type. Fortunately in tcArgs we still have access to the function, so we can check if it is a HsUnboundVar. We use this info to simply skip over any visible type arguments. We've already inferred the type of the -function, so we'll /already/ have emitted a CHoleCan constraint; +function, so we'll /already/ have emitted a Hole; failing preserves that constraint. We do /not/ want to fail altogether in this case (via failM) becuase @@ -1714,7 +1709,7 @@ do { (tclvl, wanted, (expr', sig_inst)) <- pushLevelAndCaptureConstraints $ do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ + ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ tcCheckExprNC expr (sig_inst_tau sig_inst) ; return (expr', sig_inst) } @@ -1735,7 +1730,7 @@ ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta tau_tvs qtvs (Just sig_inst) ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) + my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType @@ -1900,14 +1895,13 @@ -- Others might simply be variables that accidentally have no binding site -- -- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the CHoleCan does bind it, so it's +-- Id; and indeed the evidence for the ExprHole does bind it, so it's -- not unbound any more! tcUnboundId rn_expr occ res_ty = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) ; name <- newSysName occ ; let ev = mkLocalId name ty - ; can <- newHoleCt ExprHole ev ty - ; emitInsoluble can + ; emitNewExprHole occ ev ty ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExtField (noLoc ev)) ty res_ty } diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -31,7 +31,7 @@ , tcCheckFEType ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -66,7 +66,7 @@ funAppCtxt, addTyConFlavCtxt ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -304,7 +304,7 @@ ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) tc_lvl wanted - ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } + ; return (insolubleWC wanted, mkInfForAllTys kvs ty1) } tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type -- tcTopLHsType is used for kind-checking top-level HsType where @@ -325,7 +325,7 @@ ; spec_tkvs <- zonkAndScopedSort spec_tkvs ; let ty1 = mkSpecForAllTys spec_tkvs ty ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type - ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) + ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) ; return final_ty} @@ -419,7 +419,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so any unnamed wildcards stay unchanged in hswc_body. When called in -tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint +tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole on these anonymous wildcards. However, this would trigger error/warning when an anonymous wildcard is passed in as a visible type argument, which we do not want because users should be able to write @@ -427,7 +427,7 @@ solution is to switch the PartialTypeSignatures flags here to let the typechecker know that it's checking a '@_' and do not emit hole constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in GHC.Hs.Types +application] and Note [The wildcard story for types] in GHC.Hs.Type Ugh! @@ -717,24 +717,36 @@ --------- Foralls tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs , hst_body = ty }) exp_kind - = do { (tclvl, wanted, (tvs', ty')) + = do { (tclvl, wanted, (inv_tv_bndrs, ty')) <- pushLevelAndCaptureConstraints $ bindExplicitTKBndrs_Skol hs_tvs $ tc_lhs_type mode ty exp_kind -- Do not kind-generalise here! See Note [Kind generalisation] -- Why exp_kind? See Note [Body kind of HsForAllTy] - ; let argf = case fvf of - ForallVis -> Required - ForallInvis -> Specified - bndrs = mkTyVarBinders argf tvs' - skol_info = ForAllSkol (ppr forall) + ; let skol_info = ForAllSkol (ppr forall) m_telescope = Just (sep (map ppr hs_tvs)) - ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted - -- See Note [Skolem escape and forall-types] + ; tv_bndrs <- mapM construct_bndr inv_tv_bndrs - ; return (mkForAllTys bndrs ty') } + ; emitResidualTvConstraint skol_info m_telescope (binderVars tv_bndrs) tclvl wanted + ; return (mkForAllTys tv_bndrs ty') } + where + construct_bndr :: TcInvisTVBinder -> TcM TcTyVarBinder + construct_bndr (Bndr tv spec) = do { argf <- spec_to_argf spec + ; return $ mkTyVarBinder argf tv } + + -- See Note [Variable Specificity and Forall Visibility] + spec_to_argf :: Specificity -> TcM ArgFlag + spec_to_argf SpecifiedSpec = case fvf of + ForallVis -> return Required + ForallInvis -> return Specified + spec_to_argf InferredSpec = case fvf of + ForallVis -> do { addErrTc (hang (text "Unexpected inferred variable in visible forall binder:") + 2 (ppr forall)) + ; return Required } + ForallInvis -> return Inferred + tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind | null (unLoc ctxt) = tc_lhs_type mode rn_ty exp_kind @@ -760,7 +772,7 @@ ; checkWiredInTyCon listTyCon ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } --- See Note [Distinguishing tuple kinds] in GHC.Hs.Types +-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type -- See Note [Inferring tuple kinds] tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind -- (NB: not zonking before looking at exp_k, to avoid left-right bias) @@ -865,6 +877,29 @@ tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek +{- +Note [Variable Specificity and Forall Visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsForAllTy contains a ForAllVisFlag to denote the visibility of the forall +binder. Furthermore, each bound variable also has a Specificity. Together these +determine the variable binders (ArgFlag) for each variable in the generated +ForAllTy type. + +This table summarises this relation: +-------------------------------------------------------------------------- +| User-written type ForAllVisFlag Specificity ArgFlag +|------------------------------------------------------------------------- +| f :: forall a. type ForallInvis SpecifiedSpec Specified +| f :: forall {a}. type ForallInvis InferredSpec Inferred +| f :: forall a -> type ForallVis SpecifiedSpec Required +| f :: forall {a} -> type ForallVis InferredSpec / +| This last form is non-sensical and is thus rejected. +-------------------------------------------------------------------------- + +For more information regarding the interpretation of the resulting ArgFlag, see +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. +-} + ------------------------------------------ tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind -> TcM TcType @@ -891,7 +926,7 @@ ; warning <- woptM Opt_WarnPartialTypeSignatures ; unless (part_tysig && not warning) $ - emitAnonWildCardHoleConstraint wc_tv + emitAnonTypeHole wc_tv -- Why the 'unless' guard? -- See Note [Wildcards in visible kind application] @@ -911,14 +946,14 @@ So we should allow '@_' without emitting any hole constraints, and regardless of whether PartialTypeSignatures is enabled or not. But how would the typechecker know which '_' is being used in VKA and which is not when it -calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? +calls emitNamedTypeHole in tcHsPartialSigType on all HsWildCardBndrs? The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. And whenever we see a '@', we automatically turn on PartialTypeSignatures and -turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint +turn off hole constraint warnings, and do not call emitAnonTypeHole under these conditions. See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in GHC.Hs.Types +Note [The wildcard story for types] in GHC.Hs.Type Note [Skolem escape and forall-types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1016,28 +1051,28 @@ GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First, recall the definition of a unary tuple data type: - data Unit a = Unit a + data Solo a = Solo a -Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and -lazy. Therefore, the presence of `Unit` matters semantically. On the other +Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and +lazy. Therefore, the presence of `Solo` matters semantically. On the other hand, suppose we had a unary constraint tuple: - class a => Unit% a + class a => Solo% a -This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is +This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is semantically equivalent to `a`. Therefore, a 1-tuple constraint would have no user-visible impact, nor would it allow you to express anything that you couldn't otherwise. -We could simply add Unit% for consistency with tuples (Unit) and unboxed -tuples (Unit#), but that would require even more magic to wire in another +We could simply add Solo% for consistency with tuples (Solo) and unboxed +tuples (Solo#), but that would require even more magic to wire in another magical class, so we opt not to do so. We must be careful, however, since one can try to sneak in uses of unary constraint tuples through Template Haskell, such as in this program (from #17511): f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] (ConT ''String))) - -- f :: Unit% (Show Int) => String + -- f :: Solo% (Show Int) => String f = "abc" This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, @@ -1046,7 +1081,7 @@ trouble if one attempts to look up the name of a constraint tuple of arity 1 (as it won't exist). To avoid this trouble, we simply take any unary constraint tuples discovered when typechecking and drop them—i.e., treat -"Unit% a" as though the user had written "a". This is always safe to do +"Solo% a" as though the user had written "a". This is always safe to do since the two constraints should be semantically equivalent. -} @@ -1807,7 +1842,7 @@ -> TcM a -- Bring into scope the /named/ wildcard binders. Remember that -- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in GHC.Hs.Types +-- Soe Note [The wildcard story for types] in GHC.Hs.Type tcNamedWildCardBinders wc_names thing_inside = do { wcs <- mapM (const newWildTyVar) wc_names ; let wc_prs = wc_names `zip` wcs @@ -2204,8 +2239,8 @@ check_zipped_binder (ZippedBinder _ Nothing) = return () check_zipped_binder (ZippedBinder tb (Just b)) = case unLoc b of - UserTyVar _ _ -> return () - KindedTyVar _ v v_hs_ki -> do + UserTyVar _ _ _ -> return () + KindedTyVar _ _ v v_hs_ki -> do v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (HsTyVar noExtField NotPromoted v)) @@ -2228,14 +2263,14 @@ -- A quantifier from a kind signature zipped with a user-written binder for it. data ZippedBinder = - ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) + ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn)) -- See Note [Arity inference in kcCheckDeclHeader_sig] zipBinders :: Kind -- kind signature - -> [LHsTyVarBndr GhcRn] -- user-written binders + -> [LHsTyVarBndr () GhcRn] -- user-written binders -> ([ZippedBinder], -- zipped binders - [LHsTyVarBndr GhcRn], -- remaining user-written binders + [LHsTyVarBndr () GhcRn], -- remaining user-written binders Kind) -- remainder of the kind signature zipBinders = zip_binders [] where @@ -2249,15 +2284,14 @@ | otherwise = (ZippedBinder tb Nothing, b:bs) zippable = case tb of - Named (Bndr _ Specified) -> False - Named (Bndr _ Inferred) -> False - Named (Bndr _ Required) -> True + Named (Bndr _ (Invisible _)) -> False + Named (Bndr _ Required) -> True Anon InvisArg _ -> False Anon VisArg _ -> True in zip_binders (zb:acc) ki' bs' -tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc +tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc tooManyBindersErr ki bndrs = hang (text "Not a function kind:") 4 (ppr ki) $$ @@ -2664,9 +2698,10 @@ -------------------------------------- bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: [LHsTyVarBndr GhcRn] + :: (OutputableBndrFlag flag) + => [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([TcTyVar], a) + -> TcM ([VarBndr TyVar flag], a) bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) @@ -2675,21 +2710,30 @@ bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv :: ContextKind - -> [LHsTyVarBndr GhcRn] + -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TcTyVar], a) -bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) -bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) +bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) +bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) -- See Note [Non-cloning for tyvar binders] - -bindExplicitTKBndrsX - :: (HsTyVarBndr GhcRn -> TcM TcTyVar) - -> [LHsTyVarBndr GhcRn] +bindExplicitTKBndrsX_Q + :: (HsTyVarBndr () GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside + = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside + ; return ((binderVars tv_bndrs),res) } + +bindExplicitTKBndrsX :: (OutputableBndrFlag flag) + => (HsTyVarBndr flag GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] bindExplicitTKBndrsX tc_tv hs_tvs thing_inside = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) ; go hs_tvs } @@ -2705,33 +2749,33 @@ -- See GHC.Tc.Utils.TcMType Note [Cloning for tyvar binders] ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ go hs_tvs - ; return (tv:tvs, res) } + ; return ((Bndr tv (hsTyVarBndrFlag hs_tv)):tvs, res) } ----------------- tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar -tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) + -> HsTyVarBndr flag GhcRn -> TcM TcTyVar +tcHsTyVarBndr new_tv (UserTyVar _ _ (L _ tv_nm)) = do { kind <- newMetaKindVar ; new_tv tv_nm kind } -tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) +tcHsTyVarBndr new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; new_tv tv_nm kind } ----------------- tcHsQTyVarBndr :: ContextKind -> (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar + -> HsTyVarBndr () GhcRn -> TcM TcTyVar -- Just like tcHsTyVarBndr, but also -- - uses the in-scope TyVar from class, if it exists -- - takes a ContextKind to use for the no-sig case -tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm)) +tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ _ (L _ tv_nm)) = do { mb_tv <- tcLookupLcl_maybe tv_nm ; case mb_tv of Just (ATyVar _ tv) -> return tv _ -> do { kind <- newExpectedKind ctxt_kind ; new_tv tv_nm kind } } -tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) +tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; mb_tv <- tcLookupLcl_maybe tv_nm ; case mb_tv of @@ -3156,7 +3200,7 @@ -> LHsSigWcType GhcRn -- The type signature -> TcM ( [(Name, TcTyVar)] -- Wildcards , Maybe TcType -- Extra-constraints wildcard - , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with + , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with -- the implicitly and explicitly bound type variables , TcThetaType -- Theta part , TcType ) -- Tau part @@ -3167,7 +3211,7 @@ , hsib_body = hs_ty } <- ib_ty , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) + do { (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau))) <- solveLocalEqualities "tcHsPartialSigType" $ -- This solveLocalEqualiltes fails fast if there are -- insoluble equalities. See GHC.Tc.Solver @@ -3183,30 +3227,30 @@ ; return (wcs, wcx, theta, tau) } - -- No kind-generalization here, but perhaps some promotion - ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ - mkSpecForAllTys explicit_tvs $ + ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs + + -- No kind-generalization here: + ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $ + mkInvisForAllTys explicit_tvbndrs $ mkPhiTy theta $ tau) -- Spit out the wildcards (including the extra-constraints one) -- as "hole" constraints, so that they'll be reported if necessary -- See Note [Extra-constraint holes in partial type signatures] - ; emitNamedWildCardHoleConstraints wcs + ; mapM_ emitNamedTypeHole wcs -- Zonk, so that any nested foralls can "see" their occurrences -- See Note [Checking partial type signatures], in -- the bullet on Nested foralls. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - ; explicit_tvs <- mapM zonkTcTyVarToTyVar explicit_tvs ; theta <- mapM zonkTcType theta ; tau <- zonkTcType tau - -- We return a proper (Name,TyVar) environment, to be sure that + -- We return a proper (Name,InvisTVBinder) environment, to be sure that -- we bring the right name into scope in the function body. -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) - ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) + ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvbndrs) + ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs) -- NB: checkValidType on the final inferred type will be -- done later by checkInferredPolyId. We can't do it @@ -3338,7 +3382,7 @@ ********************************************************************* -} tcHsPatSigType :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature + -> HsPatSigType GhcRn -- The type signature -> TcM ( [(Name, TcTyVar)] -- Wildcards , [(Name, TcTyVar)] -- The new bit of type environment, binding -- the scoped type variables @@ -3346,13 +3390,13 @@ -- Used for type-checking type signatures in -- (a) patterns e.g f (x::Int) = e -- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type -- -- This may emit constraints -- See Note [Recipe for checking a signature] -tcHsPatSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = sig_ns - , hsib_body = hs_ty } <- ib_ty +tcHsPatSigType ctxt + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) = addSigCtxt ctxt hs_ty $ do { sig_tkv_prs <- mapM new_implicit_tv sig_ns ; (wcs, sig_ty) @@ -3365,7 +3409,7 @@ do { sig_ty <- tcHsOpenType hs_ty ; return (wcs, sig_ty) } - ; emitNamedWildCardHoleConstraints wcs + ; mapM_ emitNamedTypeHole wcs -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty -- contains a forall). Promote these. @@ -3385,12 +3429,12 @@ ; tv <- case ctxt of RuleSigCtxt {} -> newSkolemTyVar name kind _ -> newPatSigTyVar name kind - -- See Note [Pattern signature binders] + -- See Note [Typechecking pattern signature binders] -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) ; return (name, tv) } -{- Note [Pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Typechecking pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [Type variables in the type environment] in GHC.Tc.Utils. Consider diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -66,7 +66,7 @@ import Control.Monad import Control.Arrow ( second ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ************************************************************************ @@ -513,7 +513,7 @@ tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkInvForAllTy alphaTyVar $ + using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkVisFunTy` poly_res_ty @@ -654,7 +654,7 @@ using_arg_ty = m1_ty `mkAppTy` tup_ty poly_res_ty = m2_ty `mkAppTy` n_app alphaTy using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkInvForAllTy alphaTyVar $ + using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkVisFunTy` poly_res_ty @@ -694,8 +694,8 @@ ; fmap_op' <- case form of ThenForm -> return noExpr _ -> fmap unLoc . tcCheckExpr (noLoc fmap_op) $ - mkInvForAllTy alphaTyVar $ - mkInvForAllTy betaTyVar $ + mkInfForAllTy alphaTyVar $ + mkInfForAllTy betaTyVar $ (alphaTy `mkVisFunTy` betaTy) `mkVisFunTy` (n_app alphaTy) `mkVisFunTy` (n_app betaTy) @@ -759,7 +759,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside = do { m_ty <- newFlexiTyVarTy typeToTypeKind - ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ + ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $ (m_ty `mkAppTy` alphaTy) `mkVisFunTy` (m_ty `mkAppTy` betaTy) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -4,8 +4,10 @@ -} -{-# LANGUAGE CPP, RankNTypes, TupleSections #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -24,7 +26,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -87,7 +89,7 @@ , pe_ctxt = ctxt , pe_orig = PatOrigin } - ; tc_lpat pat pat_ty penv thing_inside } + ; tc_lpat pat_ty penv pat thing_inside } ----------------- tcPats :: HsMatchContext GhcRn @@ -108,7 +110,7 @@ -- 4. Check that no existentials escape tcPats ctxt pats pat_tys thing_inside - = tc_lpats penv pats pat_tys thing_inside + = tc_lpats pat_tys penv pats thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } @@ -117,7 +119,7 @@ -> TcM ((LPat GhcTcId, a), TcSigmaType) tcInferPat ctxt pat thing_inside = tcInfer $ \ exp_ty -> - tc_lpat pat exp_ty penv thing_inside + tc_lpat exp_ty penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } @@ -134,7 +136,7 @@ -> TcM a -- Checker for body -> TcM (LPat GhcTcId, a) tcCheckPat_O ctxt orig pat pat_ty thing_inside - = tc_lpat pat (mkCheckExpType pat_ty) penv thing_inside + = tc_lpat (mkCheckExpType pat_ty) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } @@ -291,14 +293,17 @@ -} -------------------- + type Checker inp out = forall r. - inp - -> PatEnv - -> TcM r - -> TcM (out, r) + PatEnv + -> inp + -> TcM r -- Thing inside + -> TcM ( out + , r -- Result of thing inside + ) tcMultiple :: Checker inp out -> Checker [inp] [out] -tcMultiple tc_pat args penv thing_inside +tcMultiple tc_pat penv args thing_inside = do { err_ctxt <- getErrCtxt ; let loop _ [] = do { res <- thing_inside @@ -306,7 +311,7 @@ loop penv (arg:args) = do { (p', (ps', res)) - <- tc_pat arg penv $ + <- tc_pat penv arg $ setErrCtxt err_ctxt $ loop penv args -- setErrCtxt: restore context before doing the next pattern @@ -317,52 +322,46 @@ ; loop penv args } -------------------- -tc_lpat :: LPat GhcRn - -> ExpSigmaType - -> PatEnv - -> TcM a - -> TcM (LPat GhcTcId, a) -tc_lpat (L span pat) pat_ty penv thing_inside +tc_lpat :: ExpSigmaType + -> Checker (LPat GhcRn) (LPat GhcTcId) +tc_lpat pat_ty penv (L span pat) thing_inside = setSrcSpan span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) thing_inside ; return (L span pat', res) } -tc_lpats :: PatEnv - -> [LPat GhcRn] -> [ExpSigmaType] - -> TcM a - -> TcM ([LPat GhcTcId], a) -tc_lpats penv pats tys thing_inside +tc_lpats :: [ExpSigmaType] + -> Checker [LPat GhcRn] [LPat GhcTcId] +tc_lpats tys penv pats = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) - tcMultiple (\(p,t) -> tc_lpat p t) - (zipEqual "tc_lpats" pats tys) - penv thing_inside + tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p) + penv + (zipEqual "tc_lpats" pats tys) -------------------- -tc_pat :: PatEnv - -> Pat GhcRn - -> ExpSigmaType -- Fully refined result type - -> TcM a -- Thing inside - -> TcM (Pat GhcTcId, -- Translated pattern - a) -- Result of thing inside +tc_pat :: ExpSigmaType + -- ^ Fully refined result type + -> Checker (Pat GhcRn) (Pat GhcTcId) + -- ^ Translated pattern +tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -tc_pat penv (VarPat x (L l name)) pat_ty thing_inside - = do { (wrap, id) <- tcPatBndr penv name pat_ty + VarPat x (L l name) -> do + { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } -tc_pat penv (ParPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside + ParPat x pat -> do + { (pat', res) <- tc_lpat pat_ty penv pat thing_inside ; return (ParPat x pat', res) } -tc_pat penv (BangPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside + BangPat x pat -> do + { (pat', res) <- tc_lpat pat_ty penv pat thing_inside ; return (BangPat x pat', res) } -tc_pat penv (LazyPat x pat) pat_ty thing_inside - = do { (pat', (res, pat_ct)) - <- tc_lpat pat pat_ty (makeLazy penv) $ + LazyPat x pat -> do + { (pat', (res, pat_ct)) + <- tc_lpat pat_ty (makeLazy penv) pat $ captureConstraints thing_inside -- Ignore refined penv', revert to penv @@ -376,16 +375,16 @@ ; return (LazyPat x pat', res) } -tc_pat _ (WildPat _) pat_ty thing_inside - = do { res <- thing_inside + WildPat _ -> do + { res <- thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside - = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + AsPat x (L nm_loc name) pat -> do + { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat pat (mkCheckExpType $ idType bndr_id) - penv thing_inside + tc_lpat (mkCheckExpType $ idType bndr_id) + penv pat thing_inside -- NB: if we do inference on: -- \ (y@(x::forall a. a->a)) = e -- we'll fail. The as-pattern infers a monotype for 'y', which then @@ -397,8 +396,8 @@ ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } -tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside - = do { + ViewPat _ expr pat -> do + { -- We use tcInferRho here. -- If we have a view function with types like: -- blah -> forall b. burble @@ -420,25 +419,25 @@ -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_ty) -- Check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tc_sub_type penv overall_pat_ty inf_arg_ty - -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty + ; expr_wrap2 <- tc_sub_type penv pat_ty inf_arg_ty + -- expr_wrap2 :: pat_ty "->" inf_arg_ty -- Pattern must have inf_res_ty - ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside + ; (pat', res) <- tc_lpat (mkCheckExpType inf_res_ty) penv pat thing_inside - ; overall_pat_ty <- readExpType overall_pat_ty + ; pat_ty <- readExpType pat_ty ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - overall_pat_ty inf_res_ty doc + pat_ty inf_res_ty doc -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" - -- (overall_pat_ty -> inf_res_ty) + -- (pat_ty -> inf_res_ty) expr_wrap = expr_wrap2' <.> expr_wrap1 doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} + ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} -- Type signatures in patterns -- See Note [Pattern coercions] below -tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) + SigPat _ pat sig_ty -> do + { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty -- Using tcExtendNameTyVarEnv is appropriate here -- because we're not really bringing fresh tyvars into scope. @@ -446,35 +445,35 @@ -- from an outer scope to mention one of these tyvars in its kind. ; (pat', res) <- tcExtendNameTyVarEnv wcs $ tcExtendNameTyVarEnv tv_binds $ - tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside + tc_lpat (mkCheckExpType inner_ty) penv pat thing_inside ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat Nothing pats) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside + ListPat Nothing pats -> do + { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty + ; (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty) + penv pats thing_inside ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat coi (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) } -tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside - = do { tau_pat_ty <- expTypeToType pat_ty + ListPat (Just e) pats -> do + { tau_pat_ty <- expTypeToType pat_ty ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] SynList $ \ [elt_ty] -> - do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside + do { (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty) + penv pats thing_inside ; return (pats', res, elt_ty) } ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) } -tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside - = do { let arity = length pats + TuplePat _ pats boxity -> do + { let arity = length pats tc = tupleTyCon boxity arity -- NB: tupleTyCon does not flatten 1-tuples -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make @@ -484,8 +483,8 @@ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys - ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) - thing_inside + ; (pats', res) <- tc_lpats (map mkCheckExpType con_arg_tys) + penv pats thing_inside ; dflags <- getDynFlags @@ -506,14 +505,14 @@ return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } -tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside - = do { let tc = sumTyCon arity + SumPat _ pat alt arity -> do + { let tc = sumTyCon arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv pat_ty ; -- Drop levity vars, we don't care about them here let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) - penv thing_inside + ; (pat', res) <- tc_lpat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + penv pat thing_inside ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty , res) @@ -521,13 +520,13 @@ ------------------------ -- Data constructors -tc_pat penv (ConPat NoExtField con arg_pats) pat_ty thing_inside - = tcConPat penv con pat_ty arg_pats thing_inside + ConPat NoExtField con arg_pats -> + tcConPat penv con pat_ty arg_pats thing_inside ------------------------ -- Literal patterns -tc_pat penv (LitPat x simple_lit) pat_ty thing_inside - = do { let lit_ty = hsLitType simple_lit + LitPat x simple_lit -> do + { let lit_ty = hsLitType simple_lit ; wrap <- tc_sub_type penv pat_ty lit_ty ; res <- thing_inside ; pat_ty <- readExpType pat_ty @@ -552,8 +551,8 @@ -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside - = do { let orig = LiteralOrigin over_lit + NPat _ (L l over_lit) mb_neg eq -> do + { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] (mkCheckExpType boolTy) $ @@ -601,10 +600,9 @@ -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (L nm_loc name) - (L loc lit) _ ge minus) pat_ty - thing_inside - = do { pat_ty <- expTypeToType pat_ty + NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus -> do + { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit ; (lit1', ge') <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] @@ -650,12 +648,11 @@ -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. -tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) - pat_ty thing_inside - = do addModFinalizersWithLclEnv mod_finalizers - tc_pat penv pat pat_ty thing_inside - -tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut + SplicePat _ splice -> case splice of + (HsSpliced _ mod_finalizers (HsSplicedPat pat)) -> do + { addModFinalizersWithLclEnv mod_finalizers + ; tc_pat pat_ty penv pat thing_inside } + _ -> panic "invalid splice in splice pat" {- @@ -690,7 +687,7 @@ -} tcPatSig :: Bool -- True <=> pattern binding - -> LHsSigWcType GhcRn + -> HsPatSigType GhcRn -> ExpSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [(Name,TcTyVar)], -- The new bit of type environment, binding @@ -871,7 +868,7 @@ then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' - arg_pats penv thing_inside + penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header , pat_args = arg_pats' , pat_con_ext = ConPatTc @@ -907,7 +904,7 @@ ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside + tcConArgs (RealDataCon data_con) arg_tys' penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header @@ -961,7 +958,7 @@ ; traceTc "checkConstraints {" Outputable.empty ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside + tcConArgs (PatSynCon pat_syn) arg_tys' penv arg_pats thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn @@ -1070,46 +1067,48 @@ tcConArgs :: ConLike -> [TcSigmaType] -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) -tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside - = do { checkTc (con_arity == no_of_args) -- Check correct arity +tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of + PrefixCon arg_pats -> do + { checkTc (con_arity == no_of_args) -- Check correct arity (arityErr (text "constructor") con_like con_arity no_of_args) ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys - ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys - penv thing_inside + ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys + thing_inside ; return (PrefixCon arg_pats', res) } - where - con_arity = conLikeArity con_like - no_of_args = length arg_pats + where + con_arity = conLikeArity con_like + no_of_args = length arg_pats -tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside - = do { checkTc (con_arity == 2) -- Check correct arity + InfixCon p1 p2 -> do + { checkTc (con_arity == 2) -- Check correct arity (arityErr (text "constructor") con_like con_arity 2) ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check - ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] - penv thing_inside + ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)] + thing_inside ; return (InfixCon p1' p2', res) } - where - con_arity = conLikeArity con_like + where + con_arity = conLikeArity con_like -tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside - = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside + RecCon (HsRecFields rpats dd) -> do + { (rpats', res) <- tcMultiple tc_field penv rpats thing_inside ; return (RecCon (HsRecFields rpats' dd), res) } - where - tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) - (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) - penv thing_inside - = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty sel - (occNameFS $ rdrNameOcc rdr) - ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' - pun), res) } + where + tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) + (LHsRecField GhcTcId (LPat GhcTcId)) + tc_field penv + (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) + thing_inside + = do { sel' <- tcLookupId sel + ; pat_ty <- setSrcSpan loc $ find_field_ty sel + (occNameFS $ rdrNameOcc rdr) + ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' + pun), res) } - find_field_ty :: Name -> FieldLabelString -> TcM TcType - find_field_ty sel lbl - = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of + find_field_ty :: Name -> FieldLabelString -> TcM TcType + find_field_ty sel lbl + = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of -- No matching field; chances are this field label comes from some -- other record type (or maybe none). If this happens, just fail, @@ -1124,15 +1123,14 @@ traceTc "find_field" (ppr pat_ty <+> ppr extras) ASSERT( null extras ) (return pat_ty) - field_tys :: [(FieldLabel, TcType)] - field_tys = zip (conLikeFieldLabels con_like) arg_tys + field_tys :: [(FieldLabel, TcType)] + field_tys = zip (conLikeFieldLabels con_like) arg_tys -- Don't use zipEqual! If the constructor isn't really a record, then -- dataConFieldLabels will be empty (and each field in the pattern -- will generate an error below). tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) -tcConArg (arg_pat, arg_ty) penv thing_inside - = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside +tcConArg penv (arg_pat, arg_ty) = tc_lpat (mkCheckExpType arg_ty) penv arg_pat addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -180,7 +180,7 @@ , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } -generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] +generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn -> TcM ( [TcId] , LHsExpr GhcTc, WantedConstraints @@ -204,11 +204,12 @@ ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } -- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] +tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> TcM ([TcTyVar], [Id]) tcRuleBndrs (Just bndrs) xs - = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs + = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ + tcRuleTmBndrs xs + ; let tys1 = binderVars tybndrs1 ; return (tys1 ++ tys2, tms) } tcRuleBndrs Nothing xs @@ -230,7 +231,7 @@ = do { let ctxt = RuleSigCtxt name ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty ; let id = mkLocalId name id_ty - -- See Note [Pattern signature binders] in GHC.Tc.Gen.HsType + -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType -- The type variables scope over subsequent bindings; yuk ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ @@ -460,9 +461,9 @@ = float_wc emptyVarSet wc where float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) - float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics }) + float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes }) = ( simple_yes `andCts` implic_yes - , WC { wc_simple = simple_no, wc_impl = implics_no }) + , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_holes = holes }) where (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) @@ -480,8 +481,6 @@ | EqPred _ t1 t2 <- classifyPredType (ctPred ct) , not (ok_eq t1 t2) = False -- Note [RULE quantification over equalities] - | isHoleCt ct - = False -- Don't quantify over type holes, obviously | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -23,7 +23,7 @@ mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -42,7 +42,7 @@ import GHC.Core.Type ( mkTyVarBinders ) import GHC.Driver.Session -import GHC.Types.Var ( TyVar, tyVarKind ) +import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic @@ -293,11 +293,11 @@ gos = all go -no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool +no_anon_wc_bndrs :: [LHsTyVarBndr flag GhcRn] -> Bool no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs where - go (UserTyVar _ _) = True - go (KindedTyVar _ _ ki) = no_anon_wc ki + go (UserTyVar _ _ _) = True + go (KindedTyVar _ _ _ ki) = no_anon_wc ki {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -374,15 +374,15 @@ tcPatSynSig name sig_ty | HsIB { hsib_ext = implicit_hs_tvs , hsib_body = hs_ty } <- sig_ty - , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty - , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 + , (univ_hs_tvbndrs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty + , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) + ; (implicit_tvs, (univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty)))) <- pushTcLevelM_ $ solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] bindImplicitTKBndrs_Skol implicit_hs_tvs $ - bindExplicitTKBndrs_Skol univ_hs_tvs $ - bindExplicitTKBndrs_Skol ex_hs_tvs $ + bindExplicitTKBndrs_Skol univ_hs_tvbndrs $ + bindExplicitTKBndrs_Skol ex_hs_tvbndrs $ do { req <- tcHsContext hs_req ; prov <- tcHsContext hs_prov ; body_ty <- tcHsOpenType hs_body_ty @@ -390,8 +390,8 @@ -- e.g. pattern Zero <- 0# (#12094) ; return (req, prov, body_ty) } - ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs - req ex_tvs prov body_ty + ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs + req ex_tvbndrs prov body_ty -- Kind generalisation ; kvs <- kindGeneralizeAll ungen_patsyn_ty @@ -401,8 +401,8 @@ -- unification variables. Do this after kindGeneralize which may -- default kind variables to *. ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs - ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs + ; univ_tvbndrs <- mapM zonkTyCoVarKindBinder univ_tvbndrs + ; ex_tvbndrs <- mapM zonkTyCoVarKindBinder ex_tvbndrs ; req <- zonkTcTypes req ; prov <- zonkTcTypes prov ; body_ty <- zonkTcType body_ty @@ -421,15 +421,15 @@ body_ty' = substTy env3 body_ty -} ; let implicit_tvs' = implicit_tvs - univ_tvs' = univ_tvs - ex_tvs' = ex_tvs + univ_tvbndrs' = univ_tvbndrs + ex_tvbndrs' = ex_tvbndrs req' = req prov' = prov body_ty' = body_ty -- Now do validity checking ; checkValidType ctxt $ - build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty' + build_patsyn_type kvs implicit_tvs' univ_tvbndrs' req' ex_tvbndrs' prov' body_ty' -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here @@ -439,27 +439,28 @@ ; traceTc "tcTySig }" $ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' , text "kvs" <+> ppr_tvs kvs - , text "univ_tvs" <+> ppr_tvs univ_tvs' + , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs') , text "req" <+> ppr req' - , text "ex_tvs" <+> ppr_tvs ex_tvs' + , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs') , text "prov" <+> ppr prov' , text "body_ty" <+> ppr body_ty' ] ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ - mkTyVarBinders Specified implicit_tvs' - , patsig_univ_bndrs = univ_tvs' + , patsig_implicit_bndrs = mkTyVarBinders InferredSpec kvs ++ + mkTyVarBinders SpecifiedSpec implicit_tvs' + , patsig_univ_bndrs = univ_tvbndrs' , patsig_req = req' - , patsig_ex_bndrs = ex_tvs' + , patsig_ex_bndrs = ex_tvbndrs' , patsig_prov = prov' , patsig_body_ty = body_ty' }) } where ctxt = PatSynCtxt name - build_patsyn_type kvs imp univ req ex prov body - = mkInvForAllTys kvs $ - mkSpecForAllTys (imp ++ univ) $ + build_patsyn_type kvs imp univ_bndrs req ex_bndrs prov body + = mkInfForAllTys kvs $ + mkSpecForAllTys imp $ + mkInvisForAllTys univ_bndrs $ mkPhiTy req $ - mkSpecForAllTys ex $ + mkInvisForAllTys ex_bndrs $ mkPhiTy prov $ body @@ -479,7 +480,7 @@ -- Instantiate a type signature; only used with plan InferGen tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id + do { (tv_prs, theta, tau) <- tcInstTypeBndrs newMetaTyVarTyVars poly_id -- See Note [Pattern bindings and complete signatures] ; return (TISI { sig_inst_sig = sig @@ -634,7 +635,6 @@ This wrapper is put in the TcSpecPrag, in the ABExport record of the AbsBinds. - f :: (Eq a, Ix b) => a -> b -> Bool {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} f = @@ -662,8 +662,6 @@ * The RHS of f_spec, has a *copy* of 'binds', so that it can fully specialise it. - - From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: f_spec :: Int -> b -> Int @@ -702,14 +700,14 @@ So we simply do this: - Generate a constraint to check that the specialised type (after - skolemiseation) is equal to the instantiated function type. + skolemisation) is equal to the instantiated function type. - But *discard* the evidence (coercion) for that constraint, so that we ultimately generate the simpler code f_spec :: Int -> F Int f_spec = Int dNumInt RULE: forall d. f Int d = f_spec - You can see this discarding happening in + You can see this discarding happening in tcSpecPrag 3. Note that the HsWrapper can transform *any* function with the right type prefix diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -15,6 +15,8 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -32,7 +34,7 @@ finishTH, runTopSplice ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -625,8 +627,14 @@ ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) -- The returned expression is ignored; it's in the pending splices - ; return (panic "tcSpliceExpr") } + -- But we still return a plausible expression + -- (a) in case we print it in debug messages, and + -- (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp + ; return (HsSpliceE noExtField $ + HsSpliced noExtField (ThModFinalizers []) $ + HsSplicedExpr (unLoc expr'')) } + tcNestedSplice _ _ splice_name _ _ = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) @@ -1612,7 +1620,7 @@ reifyThing (AGlobal (AConLike (PatSynCon ps))) = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSig ps) + ; ty <- reifyPatSynType (patSynSigBndr ps) ; return (TH.PatSynI name ty) } reifyThing (ATcId {tct_id = id}) @@ -1667,7 +1675,7 @@ Just name -> let thName = reifyName name injAnnot = tyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName kind') + sig = TH.TyVarSig (TH.KindedTV thName () kind') inj = case injAnnot of NotInjective -> Nothing Injective ms -> @@ -1731,7 +1739,7 @@ (ex_tvs, theta, arg_tys) = dataConInstSig dc tys -- used for GADTs data constructors - g_user_tvs' = dataConUserTyVars dc + g_user_tvs' = dataConUserTyVarBinders dc (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') = dataConFullSig dc (srcUnpks, srcStricts) @@ -1747,7 +1755,7 @@ -- See Note [Freshen reified GADT constructors' universal tyvars] <- freshenTyVarBndrs $ filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs' + ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' g_theta = substTys tvb_subst g_theta' g_arg_tys = substTys tvb_subst g_arg_tys' g_res_ty = substTy tvb_subst g_res_ty' @@ -1780,15 +1788,24 @@ ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) | otherwise = ASSERT( all isTyVar ex_tvs ) -- no covars for haskell syntax - (ex_tvs, theta) + (map mk_specified ex_tvs, theta) ret_con | null ex_tvs' && null theta' = return main_con | otherwise = do { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' + ; ex_tvs'' <- reifyTyVarBndrs ex_tvs' ; return (TH.ForallC ex_tvs'' cxt main_con) } ; ASSERT( r_arg_tys `equalLength` dcdBangs ) ret_con } + where + mk_specified tv = Bndr tv SpecifiedSpec + subst_tv_binders subst tv_bndrs = + let tvs = binderVars tv_bndrs + flags = map binderArgFlag tv_bndrs + (subst', tvs') = substTyVarBndrs subst tvs + tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) + in (subst', tv_bndrs') + {- Note [Freshen reified GADT constructors' universal tyvars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1862,9 +1879,9 @@ = (n, map bndrName args) tfNames d = pprPanic "tfNames" (text (show d)) - bndrName :: TH.TyVarBndr -> TH.Name - bndrName (TH.PlainTV n) = n - bndrName (TH.KindedTV n _) = n + bndrName :: TH.TyVarBndr flag -> TH.Name + bndrName (TH.PlainTV n _) = n + bndrName (TH.KindedTV n _ _) = n ------------------------------ -- | Annotate (with TH.SigT) a type if the first parameter is True @@ -2107,16 +2124,18 @@ reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy reify_for_all argf ty = do - tvs' <- reifyTyVars tvs + tvbndrs' <- reifyTyVarBndrs tvbndrs case argToForallVisFlag argf of ForallVis -> do phi' <- reifyType phi - pure $ TH.ForallVisT tvs' phi' + let tvs = map (() <$) tvbndrs' + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type + pure $ TH.ForallVisT tvs phi' ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi cxt' <- reifyCxt cxt tau' <- reifyType tau - pure $ TH.ForallT tvs' cxt' tau' + pure $ TH.ForallT tvbndrs' cxt' tau' where - (tvs, phi) = tcSplitForAllTysSameVis argf ty + (tvbndrs, phi) = tcSplitForAllTysSameVis argf ty reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) @@ -2126,14 +2145,14 @@ reifyTypes = mapM reifyType reifyPatSynType - :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type + :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type) -> TcM TH.Type -- reifies a pattern synonym's type and returns its *complete* type -- signature; see NOTE [Pattern synonym signatures and Template -- Haskell] reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVars univTyVars + = do { univTyVars' <- reifyTyVarBndrs univTyVars ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVars exTyVars + ; exTyVars' <- reifyTyVarBndrs exTyVars ; prov' <- reifyCxt prov ; tau' <- reifyType (mkVisFunTys argTys resTy) ; return $ TH.ForallT univTyVars' req' @@ -2148,18 +2167,37 @@ reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars tvs = mapM reify_tv tvs +class ReifyFlag flag flag' | flag -> flag' where + reifyFlag :: flag -> flag' + +instance ReifyFlag () () where + reifyFlag () = () + +instance ReifyFlag Specificity TH.Specificity where + reifyFlag SpecifiedSpec = TH.SpecifiedSpec + reifyFlag InferredSpec = TH.InferredSpec + +instance ReifyFlag ArgFlag TH.Specificity where + reifyFlag Required = TH.SpecifiedSpec + reifyFlag (Invisible s) = reifyFlag s + +reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] +reifyTyVars = reifyTyVarBndrs . map mk_bndr where + mk_bndr tv = Bndr tv () + +reifyTyVarBndrs :: ReifyFlag flag flag' + => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag'] +reifyTyVarBndrs = mapM reify_tvbndr + where -- even if the kind is *, we need to include a kind annotation, -- in case a poly-kind would be inferred without the annotation. -- See #8953 or test th/T8953 - reify_tv tv = TH.KindedTV name <$> reifyKind kind - where - kind = tyVarKind tv - name = reifyName tv + reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv) + (reifyFlag fl) + <$> reifyKind (tyVarKind tv) -reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr]) +reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()]) reifyTyVarsToMaybe [] = pure Nothing reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys @@ -2283,7 +2321,7 @@ AGlobal (AConLike (RealDataCon dc)) -> reifyType (idType (dataConWrapId dc)) AGlobal (AConLike (PatSynCon ps)) -> - reifyPatSynType (patSynSig ps) + reifyPatSynType (patSynSigBndr ps) ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType -- Impossible cases, supposedly: diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -9,7 +9,7 @@ AssocInstInfo(..), isNotAssociated ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -49,7 +49,7 @@ import qualified GHC.LanguageExtensions as LangExt -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -21,7 +21,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -10,7 +10,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -146,7 +146,7 @@ import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ************************************************************************ @@ -2444,7 +2444,7 @@ step_ty = noLoc $ HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)] + , hst_bndrs = [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)] , hst_xforall = noExtField , hst_body = nlHsFunTy ghciM ioM } @@ -2507,7 +2507,7 @@ _ <- perhaps_disable_default_warnings $ simplifyInteractive residual ; - let { all_expr_ty = mkInvForAllTys qtvs $ + let { all_expr_ty = mkInfForAllTys qtvs $ mkPhiTy (map idType dicts) res_ty } ; ty <- zonkTcType all_expr_ty ; @@ -2589,7 +2589,7 @@ -- kindGeneralize, below solveEqualities $ tcNamedWildCardBinders wcs $ \ wcs' -> - do { emitNamedWildCardHoleConstraints wcs' + do { mapM_ emitNamedTypeHole wcs' ; tcLHsTypeUnsaturated rn_type } -- Do kind generalisation; see Note [Kind-generalise in tcRnType] @@ -2608,7 +2608,7 @@ ; return ty' } else return ty ; - ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) } + ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) } {- Note [TcRnExprMode] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -24,14 +24,14 @@ approximateWC, runTcSDeriveds ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Data.Bag import GHC.Core.Class ( Class, classKey, classTyCon ) import GHC.Driver.Session -import GHC.Types.Id ( idType, mkLocalId ) +import GHC.Types.Id ( idType ) import GHC.Tc.Utils.Instantiate import GHC.Data.List.SetOps import GHC.Types.Name @@ -42,6 +42,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Solver.Interact import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) +import GHC.Tc.Solver.Flatten ( flattenType ) import GHC.Tc.Utils.TcMType as TcM import GHC.Tc.Utils.Monad as TcM import GHC.Tc.Solver.Monad as TcS @@ -145,8 +146,7 @@ ; saved_msg <- TcM.readTcRef errs_var ; TcM.writeTcRef errs_var emptyMessages - ; warnAllUnsolved $ WC { wc_simple = unsafe_ol - , wc_impl = emptyBag } + ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol } ; whyUnsafe <- fst <$> TcM.readTcRef errs_var ; TcM.writeTcRef errs_var saved_msg @@ -638,27 +638,15 @@ tcNormalise given_ids ty = do { lcl_env <- TcM.getLclEnv ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; wanted_ct <- mk_wanted_ct + ; norm_loc <- getCtLocM PatCheckOrigin Nothing ; (res, _ev_binds) <- runTcS $ do { traceTcS "tcNormalise {" (ppr given_ids) ; let given_cts = mkGivens given_loc (bagToList given_ids) ; solveSimpleGivens given_cts - ; wcs <- solveSimpleWanteds (unitBag wanted_ct) - -- It's an invariant that this wc_simple will always be - -- a singleton Ct, since that's what we fed in as input. - ; let ty' = case bagToList (wc_simple wcs) of - (ct:_) -> ctEvPred (ctEvidence ct) - cts -> pprPanic "tcNormalise" (ppr cts) + ; ty' <- flattenType norm_loc ty ; traceTcS "tcNormalise }" (ppr ty') ; pure ty' } ; return res } - where - mk_wanted_ct :: TcM Ct - mk_wanted_ct = do - let occ = mkVarOcc "$tcNorm" - name <- newSysName occ - let ev = mkLocalId name ty - newHoleCt ExprHole ev ty {- Note [Superclasses and satisfiability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -696,11 +684,8 @@ in Note [Type normalisation] in Check. To accomplish its stated goal, tcNormalise first feeds the local constraints -into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds -that singleton Ct into solveSimpleWanteds, which reduces the type in the -CHoleCan as much as possible with respect to the local given constraints. When -solveSimpleWanteds is finished, we dig out the type from the CHoleCan and -return that. +into solveSimpleGivens, then uses flattenType to simplify the desired type +with respect to the givens. *********************************************************************************** * * @@ -760,7 +745,7 @@ = do { -- When quantifying, we want to preserve any order of variables as they -- appear in partial signatures. cf. decideQuantifiedTyVars let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs - , (_,tv) <- sig_inst_skols sig ] + , (_,Bndr tv _) <- sig_inst_skols sig ] psig_theta = [ pred | sig <- partial_sigs , pred <- sig_inst_theta sig ] @@ -889,8 +874,8 @@ , ic_no_eqs = False , ic_info = skol_info } - ; return (WC { wc_simple = outer_simple - , wc_impl = implics })} + ; return (emptyWC { wc_simple = outer_simple + , wc_impl = implics })} where full_theta = map idType full_theta_vars skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) @@ -1071,7 +1056,7 @@ -- If possible, we quantify over partial-sig qtvs, so they are -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ + ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $ concatMap (map snd . sig_inst_skols) psigs ; psig_theta <- mapM TcM.zonkTcType $ @@ -1237,7 +1222,7 @@ -- See Note [Quantification and partial signatures] -- Wrinkles 2 and 3 ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,tv) <- sig_inst_skols sig ] + , (_,Bndr tv _) <- sig_inst_skols sig ] ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs , pred <- sig_inst_theta sig ] ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus @@ -1516,7 +1501,7 @@ solveWanteds :: WantedConstraints -> TcS WantedConstraints -- so that the inert set doesn't mindlessly propagate. -- NB: wc_simples may be wanted /or/ derived now -solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics }) +solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics, wc_holes = holes }) = do { cur_lvl <- TcS.getTcLevel ; traceTcS "solveWanteds {" $ vcat [ text "Level =" <+> ppr cur_lvl @@ -1530,9 +1515,12 @@ implics `unionBags` wc_impl wc1 ; dflags <- getDynFlags - ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs + ; solved_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs (wc1 { wc_impl = implics2 }) + ; holes' <- simplifyHoles holes + ; let final_wc = solved_wc { wc_holes = holes' } + ; ev_binds_var <- getTcEvBindsVar ; bb <- TcS.getTcEvBindsMap ev_binds_var ; traceTcS "solveWanteds }" $ @@ -1779,12 +1767,13 @@ then Nothing else Just final_implic } where - WC { wc_simple = simples, wc_impl = implics } = wc + WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc pruned_simples = dropDerivedSimples simples pruned_implics = filterBag keep_me implics pruned_wc = WC { wc_simple = pruned_simples - , wc_impl = pruned_implics } + , wc_impl = pruned_implics + , wc_holes = holes } -- do not prune holes; these should be reported keep_me :: Implication -> Bool keep_me ic @@ -1862,11 +1851,13 @@ ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var ; let seeds1 = foldr add_implic_seeds old_needs implics - seeds2 = foldEvBindMap add_wanted seeds1 ev_binds + seeds2 = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds + -- It's OK to use a non-deterministic fold here + -- because add_wanted is commutative seeds3 = seeds2 `unionVarSet` tcvs need_inner = findNeededEvVars ev_binds seeds3 live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds - need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds + need_outer = varSetMinusEvBindMap need_inner live_ev_binds `delVarSetList` givens ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds @@ -1890,14 +1881,19 @@ | is_given = ev_var `elemVarSet` needed | otherwise = True -- Keep all wanted bindings - del_ev_bndr :: EvBind -> VarSet -> VarSet - del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v - add_wanted :: EvBind -> VarSet -> VarSet add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs | is_given = needs -- Add the rhs vars of the Wanted bindings only | otherwise = evVarsOfTerm rhs `unionVarSet` needs +------------------------------------------------- +simplifyHoles :: Bag Hole -> TcS (Bag Hole) +simplifyHoles = mapBagM simpl_hole + where + simpl_hole :: Hole -> TcS Hole + simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) + = do { ty' <- flattenType loc ty + ; return (h { hole_ty = ty' }) } {- Note [Delete dead Given evidence bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2143,7 +2139,6 @@ is_floatable skol_tvs ct | isGivenCt ct = False - | isHoleCt ct = False | insolubleEqCt ct = False | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs @@ -2381,7 +2376,7 @@ seed_skols = mkVarSet skols `unionVarSet` mkVarSet given_ids `unionVarSet` foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` - foldEvBindMap add_one_bind emptyVarSet binds + evBindMapToVarSet binds -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) -- Include the EvIds of any non-floating constraints @@ -2406,16 +2401,13 @@ ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) } where - add_one_bind :: EvBind -> VarSet -> VarSet - add_one_bind bind acc = extendVarSet acc (evBindVar bind) - add_non_flt_ct :: Ct -> VarSet -> VarSet add_non_flt_ct ct acc | isDerivedCt ct = acc | otherwise = extendVarSet acc (ctEvId ct) is_floatable :: VarSet -> Ct -> Bool is_floatable skols ct - | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols) + | isDerivedCt ct = tyCoVarsOfCt ct `disjointVarSet` skols | otherwise = not (ctEvId ct `elemVarSet` skols) add_captured_ev_ids :: Cts -> VarSet -> VarSet diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -9,7 +9,7 @@ solveCallStack -- For GHC.Tc.Solver ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -34,12 +34,11 @@ import GHC.Types.Var import GHC.Types.Var.Env( mkInScopeSet ) import GHC.Types.Var.Set( delVarSetList ) -import GHC.Types.Name.Occurrence ( OccName ) import GHC.Utils.Outputable import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set import GHC.Types.Name.Reader -import GHC.Hs.Types( HsIPName(..) ) +import GHC.Hs.Type( HsIPName(..) ) import GHC.Data.Pair import GHC.Utils.Misc @@ -67,8 +66,7 @@ unary (i.e. treats individual constraints one at a time). Constraints originating from user-written code come into being as -CNonCanonicals (except for CHoleCans, arising from holes). We know nothing -about these constraints. So, first: +CNonCanonicals. We know nothing about these constraints. So, first: Classify CNonCanoncal constraints, depending on whether they are equalities, class predicates, or other. @@ -137,9 +135,6 @@ = {-# SCC "canEqLeafFunEq" #-} canCFunEqCan ev fn xis1 fsk -canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) - = canHole ev occ hole - {- ************************************************************************ * * @@ -718,17 +713,6 @@ _ -> continueWith $ mkIrredCt status new_ev } } -canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) -canHole ev occ hole_sort - = do { let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev - , cc_occ = occ - , cc_hole = hole_sort })) - ; stopWith new_ev "Emit insoluble hole" } } - - {- ********************************************************************* * * * Quantified predicates @@ -1401,6 +1385,7 @@ | CtDerived {} <- ev = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] ; stopWith ev "Decomposed [D] AppTy" } + | CtWanted { ctev_dest = dest } <- ev = do { co_s <- unifyWanted loc Nominal s1 s2 ; let arg_loc diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs --- a/compiler/GHC/Tc/Solver/Flatten.hs +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -5,12 +5,12 @@ module GHC.Tc.Solver.Flatten( FlattenMode(..), flatten, flattenKind, flattenArgsNom, - rewriteTyVar, + rewriteTyVar, flattenType, unflattenWanteds ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -543,6 +543,7 @@ traceFlat :: String -> SDoc -> FlatM () traceFlat herald doc = liftTcS $ traceTcS herald doc +{-# INLINE traceFlat #-} -- see Note [INLINE conditional tracing utilities] getFlatEnvField :: (FlattenEnv -> a) -> FlatM a getFlatEnvField accessor @@ -825,6 +826,20 @@ ; traceTcS "flatten }" (vcat (map ppr tys')) ; return (tys', cos, kind_co) } +-- | Flatten a type w.r.t. nominal equality. This is useful to rewrite +-- a type w.r.t. any givens. It does not do type-family reduction. This +-- will never emit new constraints. Call this when the inert set contains +-- only givens. +flattenType :: CtLoc -> TcType -> TcS TcType +flattenType loc ty + -- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint + = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $ + flatten_one ty + -- use Given flavor so that it is rewritten + -- only w.r.t. Givens, never Wanteds/Deriveds + -- (Shouldn't matter, if only Givens are present + -- anyway) + ; return xi } {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -8,7 +8,7 @@ solveSimpleWanteds, -- Solves Cts ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..), isSwapped, @@ -195,7 +195,7 @@ -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked -solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 }) +solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes }) = nestTcS $ do { solveSimples simples1 ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts @@ -204,7 +204,8 @@ -- See Note [Unflatten after solving the simple wanteds] ; return ( unif_count , WC { wc_simple = others `andCts` unflattened_eqs - , wc_impl = implics1 `unionBags` implics2 }) } + , wc_impl = implics1 `unionBags` implics2 + , wc_holes = holes }) } {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -264,7 +265,7 @@ -- 'solveSimpleWanteds' should feed the updated wanteds back into the -- main solver. runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 }) +runTcPluginsWanted wc@(WC { wc_simple = simples1 }) | isEmptyBag simples1 = return (False, wc) | otherwise @@ -285,11 +286,10 @@ ; mapM_ setEv solved_wanted ; return ( notNull (pluginNewCts p) - , WC { wc_simple = listToBag new_wanted `andCts` + , wc { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted `andCts` listToBag unsolved_derived `andCts` - listToBag insols - , wc_impl = implics1 } ) } } + listToBag insols } ) } } where setEv :: (EvTerm,Ct) -> TcS () setEv (ev,ct) = case ctEvidence ct of @@ -494,7 +494,6 @@ CIrredCan {} -> interactIrred ics wi CDictCan {} -> interactDict ics wi _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CHoleCan are put straight into inert_frozen, so never get here -- CNonCanonical have been canonicalised data InteractResult diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -125,7 +125,7 @@ -- here ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -198,7 +198,7 @@ Note [WorkList priorities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavors). +A WorkList contains canonical and non-canonical items (of all flavours). Notice that each Ct now has a simplification depth. We may consider using this depth for prioritization as well in the future. @@ -1653,8 +1653,7 @@ add_item _ item = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical, CHoleCan, - -- because they only land in inert_irreds + ppr item -- Can't be CNonCanonical because they only land in inert_irreds bumpUnsolvedCount :: CtEvidence -> Int -> Int bumpUnsolvedCount ev n | isWanted ev = n+1 @@ -1896,10 +1895,6 @@ [[Int]]" which is true, but a bit confusing because the outer type constructors match. -Similarly, if we have a CHoleCan, we'd like to rewrite it with any -Givens, to give as informative an error messasge as possible -(#12468, #11325). - Hence: * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, simpl_loop), we feed the insolubles in solveSimpleWanteds, @@ -2352,9 +2347,7 @@ CQuantCan {} -> panic "removeInertCt: CQuantCan" CIrredCan {} -> panic "removeInertCt: CIrredEvCan" CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - CHoleCan {} -> panic "removeInertCt: CHoleCan" - lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) lookupFlatCache fam_tc tys = do { IS { inert_flat_cache = flat_cache @@ -2740,6 +2733,7 @@ traceTcS :: String -> SDoc -> TcS () traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) +{-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities] runTcPluginTcS :: TcPluginM a -> TcS a runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar @@ -2758,6 +2752,7 @@ csTraceTcS :: SDoc -> TcS () csTraceTcS doc = wrapTcS $ csTraceTcM (return doc) +{-# INLINE csTraceTcS #-} -- see Note [INLINE conditional tracing utilities] traceFireTcS :: CtEvidence -> SDoc -> TcS () -- Dump a rule-firing trace @@ -2770,6 +2765,7 @@ text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) <+> doc <> colon) 4 (ppr ev)) } +{-# INLINE traceFireTcS #-} -- see Note [INLINE conditional tracing utilities] csTraceTcM :: TcM SDoc -> TcM () -- Constraint-solver tracing, -ddump-cs-trace @@ -2782,6 +2778,7 @@ (dumpOptionsFromFlag Opt_D_dump_cs_trace) "" FormatText msg }) } +{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] runTcS :: TcS a -- What to run -> TcM (a, EvBindMap) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -23,7 +23,7 @@ wrongKindOfFamily ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -1365,8 +1365,8 @@ , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred @@ -1601,10 +1601,8 @@ } kcConDecl new_or_data res_kind (ConDeclGADT - { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs + { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt + , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms }) = -- Even though the GADT-style data constructor's type is closed, -- we must still kind-check the type, because that may influence -- the inferred kind of the /type/ constructor. Example: @@ -2854,10 +2852,10 @@ -------------------------- tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo - -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder - -> HsTyPats GhcRn -- Patterns - -> LHsType GhcRn -- RHS - -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) + -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicicit binder + -> HsTyPats GhcRn -- Patterns + -> LHsType GhcRn -- RHS + -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) @@ -3116,7 +3114,7 @@ ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) + ; (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)) <- pushTcLevelM_ $ solveEqualities $ bindExplicitTKBndrs_Skol explicit_tkv_nms $ @@ -3128,12 +3126,14 @@ ; return (ctxt, arg_tys, field_lbls, stricts) } + ; let tmpl_tvs = binderVars tmpl_bndrs + -- exp_tvs have explicit, user-written binding sites -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization - ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $ - mkSpecForAllTys exp_tvs $ + ; kvs <- kindGeneralizeAll (mkSpecForAllTys tmpl_tvs $ + mkInvisForAllTys exp_tvbndrs $ mkPhiTy ctxt $ mkVisFunTys arg_tys $ unitTy) @@ -3145,20 +3145,21 @@ -- quantify over, and this type is fine for that purpose. -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrs kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; (ze, qkvs) <- zonkTyBndrs kvs + ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs + ; let user_qtvs = binderVars user_qtvbndrs + ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt ; fam_envs <- tcGetFamInstEnvs -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) ; let - univ_tvbs = tyConTyVarBinders tmpl_bndrs + univ_tvbs = tyConInvisTVBinders tmpl_bndrs univ_tvs = binderVars univ_tvbs - ex_tvbs = mkTyVarBinders Inferred qkvs ++ - mkTyVarBinders Specified user_qtvs + ex_tvbs = mkTyVarBinders InferredSpec qkvs ++ + user_qtvbndrs ex_tvs = qkvs ++ user_qtvs -- For H98 datatypes, the user-written tyvar binders are precisely -- the universals followed by the existentials. @@ -3184,17 +3185,16 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get -- the res_kind by typechecking the result type. - (ConDeclGADT { con_names = names - , con_qvars = qtvs + (ConDeclGADT { con_g_ext = implicit_tkv_nms + , con_names = names + , con_qvars = explicit_tkv_nms , con_mb_cxt = cxt, con_args = hs_args , con_res_ty = hs_res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let (L _ name : _) = names - ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + ; (imp_tvs, (exp_tvbndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise solveEqualities $ -- We won't get another crack, and we don't -- want an error cascade @@ -3217,33 +3217,27 @@ ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } ; imp_tvs <- zonkAndScopedSort imp_tvs - ; let user_tvs = imp_tvs ++ exp_tvs - ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ + ; tkvs <- kindGeneralizeAll (mkSpecForAllTys imp_tvs $ + mkInvisForAllTys exp_tvbndrs $ mkPhiTy ctxt $ mkVisFunTys arg_tys $ res_ty) + ; let tvbndrs = (mkTyVarBinders InferredSpec tkvs) + ++ (mkTyVarBinders SpecifiedSpec imp_tvs) + ++ exp_tvbndrs + -- Zonk to Types - ; (ze, tkvs) <- zonkTyBndrs tkvs - ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty + ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs + ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; res_ty <- zonkTcTypeToTypeX ze res_ty - ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst) - = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty - -- NB: this is a /lazy/ binding, so we pass six thunks to - -- buildDataCon without yet forcing the guards in rejigConRes + ; let (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) + = rejigConRes tmpl_bndrs res_tmpl tvbndrs res_ty -- See Note [Checking GADT return types] - -- Compute the user-written tyvar binders. These have the same - -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - tkv_bndrs = mkTyVarBinders Inferred tkvs' - user_tv_bndrs = mkTyVarBinders Specified user_tvs' - all_user_bndrs = tkv_bndrs ++ user_tv_bndrs - ctxt' = substTys arg_subst ctxt arg_tys' = substTys arg_subst arg_tys res_ty' = substTy arg_subst res_ty @@ -3261,7 +3255,7 @@ ; buildDataCon fam_envs name is_infix rep_nm stricts Nothing field_lbls - univ_tvs ex_tvs all_user_bndrs eq_preds + univ_tvs ex_tvs tvbndrs' eq_preds ctxt' arg_tys' res_ty' rep_tycon tag_map -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; @@ -3388,22 +3382,18 @@ rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. -- data instance T [a] b c ... -- gives template ([a,b,c], T [a] b c) - -> [TyVar] -- The constructor's inferred type variables - -> [TyVar] -- The constructor's user-written, specified - -- type variables + -> [InvisTVBinder] -- The constructor's type variables (both inferred and user-written) -> KnotTied Type -- res_ty -> ([TyVar], -- Universal [TyVar], -- Existential (distinct OccNames from univs) - [TyVar], -- The constructor's rejigged, user-written, - -- inferred type variables - [TyVar], -- The constructor's rejigged, user-written, - -- specified type variables - [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types + [InvisTVBinder], -- The constructor's rejigged, user-written + -- type variables + [EqSpec], -- Equality predicates + TCvSubst) -- Substitution to apply to argument types -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because checkValidDataCon will do it -- NB: All arguments may potentially be knot-tied -rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty +rejigConRes tmpl_bndrs res_tmpl dc_tvbndrs res_ty -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs @@ -3430,14 +3420,12 @@ -- since the dcUserTyVarBinders invariant guarantees that the -- substitution has *all* the tyvars in its domain. -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst) - substed_inferred_tvs = subst_user_tvs dc_inferred_tvs - substed_specified_tvs = subst_user_tvs dc_specified_tvs + subst_user_tvs = mapVarBndrs (getTyVar "rejigConRes" . substTyVar arg_subst) + substed_tvbndrs = subst_user_tvs dc_tvbndrs substed_eqs = map (substEqSpec arg_subst) raw_eqs in - (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs, - substed_eqs, arg_subst) + (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) | otherwise -- If the return type of the data constructor doesn't match the parent @@ -3450,10 +3438,9 @@ -- albeit bogus, relying on checkValidDataCon to check the -- bad-result-type error before seeing that the other fields look odd -- See Note [Checking GADT return types] - = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs, - [], emptyTCvSubst) + = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_tvbndrs, [], emptyTCvSubst) where - dc_tvs = dc_inferred_tvs ++ dc_specified_tvs + dc_tvs = binderVars dc_tvbndrs tmpl_tvs = binderVars tmpl_bndrs {- Note [mkGADTVars] diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -15,7 +15,7 @@ newImplicitBinder, newTyConRepName ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -106,7 +106,7 @@ -> [FieldLabel] -- Field labels -> [TyVar] -- Universals -> [TyCoVar] -- Existentials - -> [TyVarBinder] -- User-written 'TyVarBinder's + -> [InvisTVBinder] -- User-written 'TyVarBinder's -> [EqSpec] -- Equality spec -> KnotTied ThetaType -- Does not include the "stupid theta" -- or the GADT equalities @@ -164,19 +164,18 @@ -- stupid theta, taken from the TyCon arg_tyvars = tyCoVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ - tyCoVarsOfType pred `intersectVarSet` arg_tyvars + in_arg_tys pred = tyCoVarsOfType pred `intersectsVarSet` arg_tyvars ------------------------------------------------------ buildPatSyn :: Name -> Bool -> (Id,Bool) -> Maybe (Id, Bool) - -> ([TyVarBinder], ThetaType) -- ^ Univ and req - -> ([TyVarBinder], ThetaType) -- ^ Ex and prov - -> [Type] -- ^ Argument types - -> Type -- ^ Result type - -> [FieldLabel] -- ^ Field labels for - -- a record pattern synonym + -> ([InvisTVBinder], ThetaType) -- ^ Univ and req + -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov + -> [Type] -- ^ Argument types + -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym -> PatSyn buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys @@ -299,7 +298,7 @@ op_names = [op | (op,_,_) <- sig_stuff] arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas - univ_bndrs = tyConTyVarBinders binders + univ_bndrs = tyConInvisTVBinders binders univ_tvs = binderVars univ_bndrs ; rep_nm <- newTyConRepName datacon_name diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -26,7 +26,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -19,7 +19,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -836,7 +836,7 @@ ----------------------- tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] + :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr () GhcRn] -> LexicalFixity -> LHsContext GhcRn -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] -> NewOrData @@ -1306,7 +1306,7 @@ ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) ; sc_ev_id <- newEvVar sc_pred ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars $ + ; let sc_top_ty = mkInfForAllTys tyvars $ mkPhiTy (map idType dfun_evs) sc_pred sc_top_id = mkLocalId sc_top_name sc_top_ty export = ABE { abe_ext = noExtField diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -64,7 +64,7 @@ import Control.Monad ( zipWithM ) import Data.List( partition ) -#include "HsVersions.h" +#include "GhclibHsVersions.h" {- ************************************************************************ @@ -98,7 +98,7 @@ (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details mk_placeholder matcher_name = mkPatSyn name is_infix - ([mkTyVarBinder Specified alphaTyVar], []) ([], []) + ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) [] -- Arg tys alphaTy (matcher_id, True) Nothing @@ -185,9 +185,9 @@ ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) ; tc_patsyn_finish lname dir is_infix lpat' - (mkTyVarBinders Inferred univ_tvs + (mkTyVarBinders InferredSpec univ_tvs , req_theta, ev_binds, req_dicts) - (mkTyVarBinders Inferred ex_tvs + (mkTyVarBinders InferredSpec ex_tvs , mkTyVarTys ex_tvs, prov_theta, prov_evs) (map nlHsVar args, map idType args) pat_ty rec_fields } } @@ -345,17 +345,17 @@ -> TcM (LHsBinds GhcTc, TcGblEnv) tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_tvs - , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta - , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta + TPSI{ patsig_implicit_bndrs = implicit_bndrs + , patsig_univ_bndrs = explicit_univ_bndrs, patsig_prov = prov_theta + , patsig_ex_bndrs = explicit_ex_bndrs, patsig_req = req_theta , patsig_body_ty = sig_body_ty } = addPatSynCtxt lname $ do { let decl_arity = length arg_names (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details ; traceTc "tcCheckPatSynDecl" $ - vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta - , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] + vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta + , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of Right stuff -> return stuff @@ -364,7 +364,7 @@ -- Complain about: pattern P :: () => forall x. x -> P x -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity - ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs + ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs ; checkTc (null bad_tvs) $ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma , text "namely" <+> quotes (ppr pat_ty) ]) @@ -373,10 +373,10 @@ -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig ; let univ_fvs = closeOverKinds $ - (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs - univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs - ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs + (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` (binderVars explicit_univ_bndrs)) + (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_bndrs + univ_bndrs = extra_univ ++ explicit_univ_bndrs + ex_bndrs = extra_ex ++ explicit_ex_bndrs univ_tvs = binderVars univ_bndrs ex_tvs = binderVars ex_bndrs @@ -594,8 +594,8 @@ -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat GhcTc -- ^ Pattern of the PatSyn - -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) + -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) + -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and -- types -> TcType -- ^ Pattern type @@ -782,8 +782,8 @@ -} mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVarBinder] -> ThetaType - -> [TyVarBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) mkPatSynBuilderId dir (L _ name) @@ -796,8 +796,8 @@ ; let theta = req_theta ++ prov_theta need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta builder_sigma = add_void need_dummy_arg $ - mkForAllTys univ_bndrs $ - mkForAllTys ex_bndrs $ + mkInvisForAllTys univ_bndrs $ + mkInvisForAllTys ex_bndrs $ mkPhiTy theta $ mkVisFunTys arg_tys $ pat_ty diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -28,7 +28,7 @@ tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -784,7 +784,7 @@ where pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) cls_bndrs = tyConBinders (classTyCon cls) - tv_bndrs = tyConTyVarBinders cls_bndrs + tv_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders cls_bndrs -- NB: the Class doesn't have TyConBinders; we reach into its -- TyCon to get those. We /do/ need the TyConBinders because -- we need the correct visibility: these default methods are @@ -877,7 +877,7 @@ data_tv_set= tyCoVarsOfTypes inst_tys is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys data_tvbs $ + | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $ mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! -- req_theta is empty for normal DataCon mkPhiTy req_theta $ diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -72,7 +72,7 @@ import {-# SOURCE #-} GHC.Tc.Module -#include "HsVersions.h" +#include "GhclibHsVersions.h" fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc fixityMisMatch real_thing real_fixity sig_fixity = diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -69,7 +69,7 @@ mkWrapperName ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -32,7 +32,7 @@ tyCoVarsOfCt, tyCoVarsOfCts, ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -82,8 +82,8 @@ addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, -- * Error message generation (type checker) - addErrTc, addErrsTc, - addErrTcM, mkErrTcM, mkErrTc, + addErrTc, + addErrTcM, failWithTc, failWithTcM, checkTc, checkTcM, failIfTc, failIfTcM, @@ -98,14 +98,14 @@ chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, emitInsoluble, + emitImplication, emitImplications, emitInsoluble, emitHole, discardConstraints, captureConstraints, tryCaptureConstraints, pushLevelAndCaptureConstraints, pushTcLevelM_, pushTcLevelM, pushTcLevelsM, getTcLevel, setTcLevel, isTouchableTcM, getLclTypeEnv, setLclTypeEnv, traceTcConstraints, - emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, + emitNamedTypeHole, emitAnonTypeHole, -- * Template Haskell context recordThUse, recordThSpliceUse, @@ -141,7 +141,7 @@ module GHC.Data.IOEnv ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -490,22 +490,28 @@ whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () whenDOptM flag thing_inside = do b <- doptM flag when b thing_inside +{-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities] + whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () whenGOptM flag thing_inside = do b <- goptM flag when b thing_inside +{-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities] whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () whenWOptM flag thing_inside = do b <- woptM flag when b thing_inside +{-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities] whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () whenXOptM flag thing_inside = do b <- xoptM flag when b thing_inside +{-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities] unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () unlessXOptM flag thing_inside = do b <- xoptM flag unless b thing_inside +{-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities] getGhcMode :: TcRnIf gbl lcl GhcMode getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } @@ -539,10 +545,7 @@ -- order to avoid space leaks. updateEps_ :: (ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl () -updateEps_ upd_fn = do - traceIf (text "updating EPS_") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) +updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ())) getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } @@ -665,39 +668,64 @@ ************************************************************************ -} +-- Note [INLINE conditional tracing utilities] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In general we want to optimise for the case where tracing is not enabled. +-- To ensure this happens, we ensure that traceTc and friends are inlined; this +-- ensures that the allocation of the document can be pushed into the tracing +-- path, keeping the non-traced path free of this extraneous work. For +-- instance, instead of +-- +-- let thunk = ... +-- in if doTracing +-- then emitTraceMsg thunk +-- else return () +-- +-- where the conditional is buried in a non-inlined utility function (e.g. +-- traceTc), we would rather have: +-- +-- if doTracing +-- then let thunk = ... +-- in emitTraceMsg thunk +-- else return () +-- +-- See #18168. +-- -- Typechecker trace traceTc :: String -> SDoc -> TcRn () -traceTc = - labelledTraceOptTcRn Opt_D_dump_tc_trace +traceTc herald doc = + labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc +{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities] -- Renamer Trace traceRn :: String -> SDoc -> TcRn () -traceRn = - labelledTraceOptTcRn Opt_D_dump_rn_trace +traceRn herald doc = + labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc +{-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities] -- | Trace when a certain flag is enabled. This is like `traceOptTcRn` -- but accepts a string as a label and formats the trace message uniformly. labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () -labelledTraceOptTcRn flag herald doc = do - traceOptTcRn flag (formatTraceMsg herald doc) +labelledTraceOptTcRn flag herald doc = + traceOptTcRn flag (formatTraceMsg herald doc) +{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] formatTraceMsg :: String -> SDoc -> SDoc formatTraceMsg herald doc = hang (text herald) 2 doc --- | Trace if the given 'DumpFlag' is set. traceOptTcRn :: DumpFlag -> SDoc -> TcRn () traceOptTcRn flag doc = do - dflags <- getDynFlags - when (dopt flag dflags) $ + whenDOptM flag $ dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc +{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Dump if the given 'DumpFlag' is set. dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpOptTcRn flag title fmt doc = do - dflags <- getDynFlags - when (dopt flag dflags) $ + whenDOptM flag $ dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc +{-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Unconditionally dump some trace output -- @@ -712,8 +740,8 @@ printer <- getPrintUnqualified dflags real_doc <- wrapDocLoc doc let sty = if useUserStyle - then mkUserStyle dflags printer AllTheWay - else mkDumpStyle dflags printer + then mkUserStyle printer AllTheWay + else mkDumpStyle printer liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc -- | Add current location if -dppr-debug @@ -749,13 +777,16 @@ traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs - +{-# INLINE traceIf #-} +{-# INLINE traceHiDiffs #-} + -- see Note [INLINE conditional tracing utilities] traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc = whenDOptM flag $ -- No RdrEnv available, so qualify everything do { dflags <- getDynFlags ; liftIO (putMsg dflags doc) } +{-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] {- ************************************************************************ @@ -1281,27 +1312,12 @@ addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrsTc :: [MsgDoc] -> TcM () -addErrsTc err_msgs = mapM_ addErrTc err_msgs - addErrTcM :: (TidyEnv, MsgDoc) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; add_err_tcm tidy_env err_msg loc ctxt } --- Return the error message, instead of reporting it straight away -mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg -mkErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - err_info <- mkErrInfo tidy_env ctxt ; - mkLongErrAt loc err_msg err_info } - -mkErrTc :: MsgDoc -> TcM ErrMsg -mkErrTc msg = do { env0 <- tcInitTidyEnv - ; mkErrTcM (env0, msg) } - -- The failWith functions add an error message and cause failure failWithTc :: MsgDoc -> TcM a -- Add an error message and fail @@ -1569,12 +1585,11 @@ ; lie_var <- getConstraintVar ; updTcRef lie_var (`addInsols` unitBag ct) } -emitInsolubles :: Cts -> TcM () -emitInsolubles cts - | isEmptyBag cts = return () - | otherwise = do { traceTc "emitInsolubles" (ppr cts) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` cts) } +emitHole :: Hole -> TcM () +emitHole hole + = do { traceTc "emitHole" (ppr hole) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addHole` hole) } -- | Throw out any constraints emitted by the thing_inside discardConstraints :: TcM a -> TcM a @@ -1644,34 +1659,28 @@ hang (text (msg ++ ": LIE:")) 2 (ppr lie) } -emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () -emitAnonWildCardHoleConstraint tv - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ unitBag $ - CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc } - , cc_occ = mkTyVarOcc "_" - , cc_hole = TypeHole } } +emitAnonTypeHole :: TcTyVar -> TcM () +emitAnonTypeHole tv + = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing + ; let hole = Hole { hole_sort = TypeHole + , hole_occ = occ + , hole_ty = mkTyVarTy tv + , hole_loc = ct_loc } + ; emitHole hole } + where + occ = mkTyVarOcc "_" -emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitNamedWildCardHoleConstraints wcs - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ listToBag $ - map (do_one ct_loc) wcs } +emitNamedTypeHole :: (Name, TcTyVar) -> TcM () +emitNamedTypeHole (name, tv) + = do { ct_loc <- setSrcSpan (nameSrcSpan name) $ + getCtLocM (TypeHoleOrigin occ) Nothing + ; let hole = Hole { hole_sort = TypeHole + , hole_occ = occ + , hole_ty = mkTyVarTy tv + , hole_loc = ct_loc } + ; emitHole hole } where - do_one :: CtLoc -> (Name, TcTyVar) -> Ct - do_one ct_loc (name, tv) - = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc' } - , cc_occ = occName name - , cc_hole = TypeHole } - where - real_span = case nameSrcSpan name of - RealSrcSpan span _ -> span - UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" - (ppr name <+> quotes (ftext str)) - -- Wildcards are defined locally, and so have RealSrcSpans - ct_loc' = setCtLocSpan ct_loc real_span + occ = nameOccName name {- Note [Constraints and errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1902,7 +1911,7 @@ ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; dflags <- getDynFlags ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan (defaultErrStyle dflags) full_msg) + noSrcSpan $ withPprStyle (defaultErrStyle dflags) full_msg) ; failM } -------------------- @@ -1938,8 +1947,7 @@ NoReason SevFatal noSrcSpan - (defaultErrStyle dflags) - msg + $ withPprStyle (defaultErrStyle dflags) msg ; traceIf (text "} ending fork (badly)" <+> doc) ; return Nothing } diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -41,10 +41,11 @@ -------------------------------- -- Creating new evidence variables newEvVar, newEvVars, newDict, - newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC, + newWanted, newWanteds, cloneWanted, cloneWC, emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, emitDerivedEqs, newTcEvBinds, newNoTcEvBinds, addTcEvBind, + emitNewExprHole, newCoercionHole, fillCoercionHole, isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe, @@ -58,7 +59,7 @@ newMetaTyVarTyVars, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX, - tcInstType, + tcInstType, tcInstTypeBndrs, tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, @@ -67,7 +68,7 @@ -------------------------------- -- Zonking and tidying zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, - tidyEvVar, tidyCt, tidySkolemInfo, + tidyEvVar, tidyCt, tidyHole, tidySkolemInfo, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarToTyVar, zonkTyVarTyVarPairs, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, @@ -78,7 +79,7 @@ zonkAndSkolemise, skolemiseQuantifiedTyVar, defaultTyVar, quantifyTyVars, isQuantifiableTv, zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, + zonkTyCoVarKind, zonkTyCoVarKindBinder, zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCoVar, @@ -91,7 +92,7 @@ ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" -- friends: import GHC.Prelude @@ -193,17 +194,6 @@ newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] newWanteds orig = mapM (newWanted orig Nothing) --- | Create a new 'CHoleCan' 'Ct'. -newHoleCt :: HoleSort -> Id -> Type -> TcM Ct -newHoleCt hole ev ty = do - loc <- getCtLocM HoleOrigin Nothing - pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty - , ctev_dest = EvVarDest ev - , ctev_nosh = WDeriv - , ctev_loc = loc } - , cc_occ = getOccName ev - , cc_hole = hole } - ---------------------------------------------- -- Cloning constraints ---------------------------------------------- @@ -286,6 +276,18 @@ emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] emitWantedEvVars orig = mapM (emitWantedEvVar orig) +-- | Emit a new wanted expression hole +emitNewExprHole :: OccName -- of the hole + -> Id -- of the evidence + -> Type -> TcM () +emitNewExprHole occ ev_id ty + = do { loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel) + ; let hole = Hole { hole_sort = ExprHole ev_id + , hole_occ = getOccName ev_id + , hole_ty = ty + , hole_loc = loc } + ; emitHole hole } + newDict :: Class -> [TcType] -> TcM DictId newDict cls tys = do { name <- newSysName (mkDictOcc (getOccName cls)) @@ -505,23 +507,55 @@ * * ********************************************************************* -} +tc_inst_internal :: ([VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TcTyVar flag])) + -- ^ How to instantiate the type variables + -> [VarBndr TyVar flag] -- ^ Type variable to instantiate + -> Type -- ^ rho + -> TcM ([(Name, VarBndr TcTyVar flag)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tc_inst_internal _inst_tyvars [] rho = + let -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + (theta, tau) = tcSplitPhiTy rho + in + return ([], theta, tau) +tc_inst_internal inst_tyvars tyvars rho = + do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) + tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars' + ; return (tv_prs, theta, tau) } + tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result + -> Id -- ^ Type to instantiate + -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id - = case tcSplitForAllTys (idType id) of - ([], rho) -> let -- There may be overloading despite no type variables; - -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) +tcInstType inst_tyvars id = + do { let (tyvars, rho) = splitForAllTys (idType id) + tyvars' = mkTyVarBinders () tyvars + ; (tv_prs, preds, rho) <- tc_inst_internal inst_tyvar_bndrs tyvars' rho + ; let tv_prs' = map (\(name, bndr) -> (name, binderVar bndr)) tv_prs + ; return (tv_prs', preds, rho) } + where + inst_tyvar_bndrs :: [VarBndr TyVar ()] -> TcM (TCvSubst, [VarBndr TcTyVar ()]) + inst_tyvar_bndrs bndrs = do { (subst, tvs) <- inst_tyvars $ binderVars bndrs + ; let tvbnds = map (\tv -> Bndr tv ()) tvs + ; return (subst, tvbnds) } - (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars - ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) - tv_prs = map tyVarName tyvars `zip` tyvars' - ; return (tv_prs, theta, tau) } +tcInstTypeBndrs :: ([VarBndr TyVar Specificity] -> TcM (TCvSubst, [VarBndr TcTyVar Specificity])) + -- ^ How to instantiate the type variables + -> Id -- ^ Type to instantiate + -> TcM ([(Name, VarBndr TcTyVar Specificity)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tcInstTypeBndrs inst_tyvars id = + let (tyvars, rho) = splitForAllVarBndrs (idType id) + tyvars' = map argf_to_spec tyvars + in tc_inst_internal inst_tyvars tyvars' rho + where + argf_to_spec :: VarBndr TyCoVar ArgFlag -> VarBndr TyCoVar Specificity + argf_to_spec (Bndr tv Required) = Bndr tv SpecifiedSpec + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type + argf_to_spec (Bndr tv (Invisible s)) = Bndr tv s tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants. @@ -998,12 +1032,16 @@ -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar -newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVarTyVars :: [VarBndr TyVar Specificity] + -> TcM (TCvSubst, [VarBndr TcTyVar Specificity]) newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst -newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newMetaTyVarTyVarX :: TCvSubst -> (VarBndr TyVar Specificity) + -> TcM (TCvSubst, VarBndr TcTyVar Specificity) -- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar +newMetaTyVarTyVarX subst (Bndr tv spec) = + do { (subst', tv') <- new_meta_tv_x TyVarTv subst tv + ; return (subst', (Bndr tv' spec)) } newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) newWildCardX subst tv @@ -1970,6 +2008,10 @@ zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind') } +zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl) +zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv) + ; return $ Bndr (setTyVarKind tv kind') fl } + {- ************************************************************************ * * @@ -2002,21 +2044,28 @@ zonkWC wc = zonkWCRec wc zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic }) +zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes }) = do { simple' <- zonkSimples simple ; implic' <- mapBagM zonkImplication implic - ; return (WC { wc_simple = simple', wc_impl = implic' }) } + ; holes' <- mapBagM zonkHole holes + ; return (WC { wc_simple = simple', wc_impl = implic', wc_holes = holes' }) } zonkSimples :: Cts -> TcM Cts zonkSimples cts = do { cts' <- mapBagM zonkCt cts ; traceTc "zonkSimples done:" (ppr cts') ; return cts' } +zonkHole :: Hole -> TcM Hole +zonkHole hole@(Hole { hole_ty = ty }) + = do { ty' <- zonkTcType ty + ; return (hole { hole_ty = ty' }) } + -- No need to zonk the Id in any ExprHole because we never look at it + -- until after the final zonk and desugaring + {- Note [zonkCt behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct. For example, - a CDictCan should stay a CDictCan; - - a CHoleCan should stay a CHoleCan - a CIrredCan should stay a CIrredCan with its cc_status flag intact Why?, for example: @@ -2026,8 +2075,6 @@ don't preserve a canonical form, @expandSuperClasses@ fails to expand superclasses. This is what happened in #11525. -- For CHoleCan, once we forget that it's a hole, we can never recover that info. - - For CIrredCan we want to see if a constraint is insoluble with insolubleWC On the other hand, we change CTyEqCan to CNonCanonical, because of all of @@ -2046,10 +2093,6 @@ zonkCt :: Ct -> TcM Ct -- See Note [zonkCt behaviour] -zonkCt ct@(CHoleCan { cc_ev = ev }) - = do { ev' <- zonkCtEvidence ev - ; return $ ct { cc_ev = ev' } } - zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) = do { ev' <- zonkCtEvidence ev ; args' <- mapM zonkTcType args @@ -2175,12 +2218,12 @@ (ppr tv $$ ppr ty) ; return tv' } -zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)] +zonkTyVarTyVarPairs :: [(Name,VarBndr TcTyVar Specificity)] -> TcM [(Name,VarBndr TcTyVar Specificity)] zonkTyVarTyVarPairs prs = mapM do_one prs where - do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv - ; return (nm, tv') } + do_one (nm, Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv + ; return (nm, Bndr tv' spec) } -- zonkId is used *during* typechecking just to zonk the Id's type zonkId :: TcId -> TcM TcId @@ -2262,17 +2305,15 @@ tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting tidyCt env ct - = ct { cc_ev = tidy_ev env (ctEvidence ct) } + = ct { cc_ev = tidy_ev (ctEvidence ct) } where - tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence + tidy_ev :: CtEvidence -> CtEvidence -- NB: we do not tidy the ctev_evar field because we don't -- show it in error messages - tidy_ev env ctev@(CtGiven { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtWanted { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtDerived { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } + tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) } + +tidyHole :: TidyEnv -> Hole -> Hole +tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -38,7 +38,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot --- a/compiler/GHC/Tc/Utils/Unify.hs-boot +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -5,7 +5,7 @@ import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion ) import GHC.Hs.Expr ( HsExpr ) -import GHC.Hs.Types ( HsType ) +import GHC.Hs.Type ( HsType ) import GHC.Hs.Extension ( GhcRn ) -- This boot file exists only to tie the knot between diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -44,7 +44,7 @@ lookupTyVarOcc ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -20,7 +20,7 @@ allDistinctTyVars ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude @@ -2734,7 +2734,8 @@ at all in the kind -- after all, it is Specified so it must have occurred. (It /used/ to be possible; see tests T13983 and T7873. But with the advent of the forall-or-nothing rule for kind variables, -those strange cases went away.) +those strange cases went away. See Note [forall-or-nothing rule] in +GHC.Rename.HsType.) But one might worry about type v k = * diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -6,11 +6,15 @@ This module converts Template Haskell syntax into Hs syntax -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -34,7 +38,7 @@ import GHC.Parser.PostProcess import GHC.Types.Name.Occurrence as OccName import GHC.Types.SrcLoc -import GHC.Core.Type +import GHC.Core.Type as Hs import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Types.Basic as Hs @@ -134,15 +138,15 @@ -- E.g wrapMsg "declaration" dec thing wrapMsg what item (CvtM m) = CvtM $ \origin loc -> case m origin loc of - Left err -> Left (err $$ getPprStyle msg) + Left err -> Left (err $$ msg) Right v -> Right v where -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug - msg sty = hang (text "When splicing a TH" <+> text what <> colon) - 2 (if debugStyle sty - then text (show item) - else text (pprint item)) + msg = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (pprint item)) wrapL :: CvtM a -> CvtM (Located a) wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of @@ -476,7 +480,7 @@ ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- -cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] -> CvtM ( LHsContext GhcPs , Located RdrName , LHsQTyVars GhcPs) @@ -484,13 +488,13 @@ = do { cxt' <- cvtContext funPrec cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') + ; return (cxt', tc', mkHsQTvs tvs') } -cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type +cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type -> CvtM ( LHsContext GhcPs , Located RdrName - , Maybe [LHsTyVarBndr GhcPs] + , Maybe [LHsTyVarBndr () GhcPs] , HsTyPats GhcPs) cvt_datainst_hdr cxt bndrs tys = do { cxt' <- cvtContext funPrec cxt @@ -593,18 +597,20 @@ add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) - , con_qvars = mkHsQTvs all_tvs + , con_qvars = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where - all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars + all_tvs = tvs' ++ qvars add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) , con_ex_tvs = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where - all_tvs = hsQTvExplicit tvs' ++ ex_tvs + all_tvs = tvs' ++ ex_tvs + add_forall _ _ (XConDecl nec) = noExtCon nec + cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name") @@ -762,7 +768,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm ; let act = cvtPhases phases AlwaysActive - ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs + ; ty_bndrs' <- traverse cvtTvs ty_bndrs ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs @@ -829,7 +835,7 @@ cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' } + ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkHsPatSigType ty' } --------------------------------------------------- -- Declarations @@ -1227,8 +1233,7 @@ cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' ; return $ HsString (quotedSourceText s) s' } -cvtLit (StringPrimL s) = do { let { s' = BS.pack s } - ; force s' +cvtLit (StringPrimL s) = do { let { !s' = BS.pack s } ; return $ HsStringPrim NoSourceText s' } cvtLit (BytesPrimL (Bytes fptr off sz)) = do let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> @@ -1306,7 +1311,7 @@ ; return $ ListPat noExtField ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noExtField p' (mkLHsSigWcType t') } + ; return $ SigPat noExtField p' (mkHsPatSigType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noExtField e' p'} @@ -1341,17 +1346,29 @@ ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) -cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } +class CvtFlag flag flag' | flag -> flag' where + cvtFlag :: flag -> flag' -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) -cvt_tv (TH.PlainTV nm) +instance CvtFlag () () where + cvtFlag () = () + +instance CvtFlag TH.Specificity Hs.Specificity where + cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec + cvtFlag TH.InferredSpec = Hs.InferredSpec + +cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] +cvtTvs tvs = mapM cvt_tv tvs + +cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs) +cvt_tv (TH.PlainTV nm fl) = do { nm' <- tNameL nm - ; returnL $ UserTyVar noExtField nm' } -cvt_tv (TH.KindedTV nm ki) + ; let fl' = cvtFlag fl + ; returnL $ UserTyVar noExtField fl' nm' } +cvt_tv (TH.KindedTV nm fl ki) = do { nm' <- tNameL nm + ; let fl' = cvtFlag fl ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExtField nm' ki' } + ; returnL $ KindedTyVar noExtField fl' nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1457,17 +1474,19 @@ ; cxt' <- cvtContext funPrec cxt ; ty' <- cvtType ty ; loc <- getL - ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty + ; let hs_ty = mkHsForAllTy loc ForallInvis tvs' rho_ty rho_ty = mkHsQualTy cxt loc cxt' ty' ; return hs_ty } ForallVisT tvs ty | null tys' - -> do { tvs' <- cvtTvs tvs - ; ty' <- cvtType ty - ; loc <- getL - ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' } + -> do { let tvs_spec = map (TH.SpecifiedSpec <$) tvs + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type + ; tvs_spec' <- cvtTvs tvs_spec + ; ty' <- cvtType ty + ; loc <- getL + ; pure $ mkHsForAllTy loc ForallVis tvs_spec' ty' } SigT ty ki -> do { ty' <- cvtType ty @@ -1704,7 +1723,7 @@ , hst_xqual = noExtField , hst_body = ty' }) } | null reqs = do { l <- getL - ; univs' <- hsQTvExplicit <$> cvtTvs univs + ; univs' <- cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) ; let forTy = HsForAllTy { hst_fvf = ForallInvis @@ -1754,27 +1773,25 @@ | otherwise = return () --- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the +-- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' -- using the provided 'LHsQTyVars' and 'LHsType'. -mkHsForAllTy :: [TH.TyVarBndr] - -- ^ The original Template Haskell type variable binders - -> SrcSpan +mkHsForAllTy :: SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall -> ForallVisFlag -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@) -- or invisible (e.g., @forall a.@) - -> LHsQTyVars GhcPs + -> [LHsTyVarBndr Hs.Specificity GhcPs] -- ^ The converted type variable binders -> LHsType GhcPs -- ^ The converted rho type -> LHsType GhcPs -- ^ The complete type, quantified with a forall if necessary -mkHsForAllTy tvs loc fvf tvs' rho_ty +mkHsForAllTy loc fvf tvs rho_ty | null tvs = rho_ty | otherwise = L loc $ HsForAllTy { hst_fvf = fvf - , hst_bndrs = hsQTvExplicit tvs' + , hst_bndrs = tvs , hst_xforall = noExtField , hst_body = rho_ty } @@ -2015,7 +2032,7 @@ Due to the two forall quantifiers and constraint contexts (either of which might be empty), pattern synonym type signatures are treated specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and -`typecheck/GHC.Tc.Gen.Splice.hs`: +`GHC.Tc.Gen.Splice`: (a) When desugaring a pattern synonym from HsSyn to TH.Dec in `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.: @@ -2024,7 +2041,7 @@ (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) (b) When converting pattern synonyms from TH.Dec to HsSyn in - `hsSyn/Convert.hs`, we convert their TH type signatures back to an + `GHC.ThToHs`, we convert their TH type signatures back to an appropriate Haskell pattern synonym type of the form forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t @@ -2032,7 +2049,7 @@ where initial empty `univs` type variables or an empty `reqs` constraint context are represented *explicitly* as `() =>`. - (c) When reifying a pattern synonym in `typecheck/GHC.Tc.Gen.Splice.hs`, we always + (c) When reifying a pattern synonym in `GHC.Tc.Gen.Splice`, we always return its *full* type, i.e.: ForallT univs reqs (ForallT exis provs ty) diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -11,7 +11,7 @@ ) where -#include "HsVersions.h" +#include "GhclibHsVersions.h" import GHC.Prelude diff --git a/compiler/GhclibHsVersions.h b/compiler/GhclibHsVersions.h new file mode 100644 --- /dev/null +++ b/compiler/GhclibHsVersions.h @@ -0,0 +1,56 @@ +#pragma once + +-- For GHC_STAGE +#include "ghcplatform.h" + +#if 0 + +IMPORTANT! If you put extra tabs/spaces in these macro definitions, +you will screw up the layout where they are used in case expressions! + +(This is cpp-dependent, of course) + +#endif + +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = GHC.Utils.Misc.global (value); + +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = GHC.Utils.Misc.globalM (value); + + +#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = GHC.Utils.Misc.sharedGlobal (value) (accessor); \ +foreign import ccall unsafe saccessor \ + accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); + +#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = GHC.Utils.Misc.sharedGlobalM (value) (accessor); \ +foreign import ccall unsafe saccessor \ + accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); + + +#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else +#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else +#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ + +-- Examples: Assuming flagSet :: String -> m Bool +-- +-- do { c <- getChar; MASSERT( isUpper c ); ... } +-- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } +-- do { str <- getStr; ASSERTM( flagSet str ); .. } +-- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } +-- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } +#define MASSERT(e) ASSERT(e) return () +#define MASSERT2(e,msg) ASSERT2(e,msg) return () +#define ASSERTM(e) do { bool <- e; MASSERT(bool) } +#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } +#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h deleted file mode 100644 --- a/compiler/HsVersions.h +++ /dev/null @@ -1,56 +0,0 @@ -#pragma once - --- For GHC_STAGE -#include "ghcplatform.h" - -#if 0 - -IMPORTANT! If you put extra tabs/spaces in these macro definitions, -you will screw up the layout where they are used in case expressions! - -(This is cpp-dependent, of course) - -#endif - -#define GLOBAL_VAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = GHC.Utils.Misc.global (value); - -#define GLOBAL_VAR_M(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = GHC.Utils.Misc.globalM (value); - - -#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = GHC.Utils.Misc.sharedGlobal (value) (accessor); \ -foreign import ccall unsafe saccessor \ - accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); - -#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = GHC.Utils.Misc.sharedGlobalM (value) (accessor); \ -foreign import ccall unsafe saccessor \ - accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); - - -#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else -#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else -#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ - --- Examples: Assuming flagSet :: String -> m Bool --- --- do { c <- getChar; MASSERT( isUpper c ); ... } --- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } --- do { str <- getStr; ASSERTM( flagSet str ); .. } --- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } --- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } -#define MASSERT(e) ASSERT(e) return () -#define MASSERT2(e,msg) ASSERT2(e,msg) return () -#define ASSERTM(e) do { bool <- e; MASSERT(bool) } -#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } -#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20200501 +version: 0.20200601 license: BSD3 license-file: LICENSE category: Development @@ -45,7 +45,7 @@ includes/MachDeps.h includes/stg/MachRegs.h includes/CodeGen.Platform.hs - compiler/HsVersions.h + compiler/GhclibHsVersions.h compiler/Unique.h tested-with: GHC==8.10.1, GHC==8.8.2, GHC==8.6.5, GHC==8.4.4 source-repository head @@ -83,7 +83,8 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*, - ghc-lib-parser == 0.20200501 + exceptions == 0.10.*, + ghc-lib-parser == 0.20200601 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -129,7 +130,6 @@ autogen-modules: Paths_ghc_lib reexported-modules: - Config, GHC.BaseDir, GHC.Builtin.Names, GHC.Builtin.PrimOps, @@ -151,7 +151,6 @@ GHC.Cmm.Type, GHC.CmmToAsm.Config, GHC.Core, - GHC.Core.Arity, GHC.Core.Class, GHC.Core.Coercion, GHC.Core.Coercion.Axiom, @@ -163,6 +162,7 @@ GHC.Core.InstEnv, GHC.Core.Make, GHC.Core.Map, + GHC.Core.Opt.Arity, GHC.Core.Opt.ConstantFold, GHC.Core.Opt.Monad, GHC.Core.Opt.OccurAnal, @@ -232,7 +232,7 @@ GHC.Hs.Instances, GHC.Hs.Lit, GHC.Hs.Pat, - GHC.Hs.Types, + GHC.Hs.Type, GHC.Hs.Utils, GHC.HsToCore.PmCheck.Types, GHC.Iface.Recomp.Binary, @@ -267,6 +267,7 @@ GHC.Runtime.Linker.Types, GHC.Serialized, GHC.Settings, + GHC.Settings.Config, GHC.Settings.Constants, GHC.Stg.Syntax, GHC.SysTools.BaseDir, diff --git a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl @@ -213,6 +213,7 @@ primOpCanFail WriteOffAddrOp_Word64 = True primOpCanFail AtomicModifyMutVar2Op = True primOpCanFail AtomicModifyMutVar_Op = True +primOpCanFail RaiseOp = True primOpCanFail ReallyUnsafePtrEqualityOp = True primOpCanFail (VecInsertOp _ _ _) = True primOpCanFail (VecDivOp _ _ _) = True diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -78,11 +78,11 @@ , ("thawArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("casArray#","Given an array, an offset, the expected old value, and\n the new value, perform an atomic compare and swap (i.e. write the new\n value if the current value and the old value are the same pointer).\n Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n the element at the offset after the operation completes. This means that\n on a success the new value is returned, and on a failure the actual old\n value (not the expected one) is returned. Implies a full memory barrier.\n The use of a pointer equality on a lifted value makes this function harder\n to use correctly than @casIntArray\\#@. All of the difficulties\n of using @reallyUnsafePtrEquality\\#@ correctly apply to\n @casArray\\#@ as well.\n ") , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n in the specified state thread,\n with each element containing the specified initial value.") - , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @sizeofSmallMutableArray\\#@.") + , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @getSizeofSmallMutableArray\\#@.") , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.") , ("writeSmallArray#","Write to specified index of mutable array.") , ("sizeofSmallArray#","Return the number of elements in the array.") - , ("sizeofSmallMutableArray#","Return the number of elements in the array. Note that this is deprecated\n as it is unsafe in the presence of resize operations on the\n same byte array.") + , ("sizeofSmallMutableArray#","Return the number of elements in the array. Note that this is deprecated\n as it is unsafe in the presence of shrink and resize operations on the\n same small mutable array.") , ("getSizeofSmallMutableArray#","Return the number of elements in the array.") , ("indexSmallArray#","Read from specified index of immutable array. Result is packaged into\n an unboxed singleton; the result itself is not yet evaluated.") , ("unsafeFreezeSmallArray#","Make a mutable array immutable, without copying.") @@ -100,11 +100,11 @@ , ("isMutableByteArrayPinned#","Determine whether a @MutableByteArray\\#@ is guaranteed not to move\n during GC.") , ("isByteArrayPinned#","Determine whether a @ByteArray\\#@ is guaranteed not to move during GC.") , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!") - , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @sizeofMutableByteArray\\#@.") + , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @getSizeofMutableByteArray\\#@.") , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n The returned @MutableByteArray\\#@ is either the original\n @MutableByteArray\\#@ resized in-place or, if not possible, a newly\n allocated (unpinned) @MutableByteArray\\#@ (with the original content\n copied over).\n\n To avoid undefined behaviour, the original @MutableByteArray\\#@ shall\n not be accessed anymore after a @resizeMutableByteArray\\#@ has been\n performed. Moreover, no reference to the old one should be kept in order\n to allow garbage collection of the original @MutableByteArray\\#@ in\n case a new @MutableByteArray\\#@ had to be allocated.") , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.") , ("sizeofByteArray#","Return the size of the array in bytes.") - , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n unsafe in the presence of resize operations on the same byte\n array.") + , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n unsafe in the presence of shrink and resize operations on the same mutable byte\n array.") , ("getSizeofMutableByteArray#","Return the number of elements in the array.") , ("indexCharArray#","Read 8-bit character; offset in bytes.") , ("indexWideCharArray#","Read 31-bit character; offset in 4-byte words.") diff --git a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl @@ -155,7 +155,6 @@ primOpHasSideEffects AtomicModifyMutVar_Op = True primOpHasSideEffects CasMutVarOp = True primOpHasSideEffects CatchOp = True -primOpHasSideEffects RaiseOp = True primOpHasSideEffects RaiseDivZeroOp = True primOpHasSideEffects RaiseUnderflowOp = True primOpHasSideEffects RaiseOverflowOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -5,6 +5,7 @@ primOpStrictness RaiseDivZeroOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv primOpStrictness RaiseUnderflowOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv primOpStrictness RaiseOverflowOp = \ _arity -> mkClosedStrictSig [topDmd] botDiv +primOpStrictness RaiseIOOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnDiv primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv diff --git a/ghc-lib/stage0/lib/ghcautoconf.h b/ghc-lib/stage0/lib/ghcautoconf.h --- a/ghc-lib/stage0/lib/ghcautoconf.h +++ b/ghc-lib/stage0/lib/ghcautoconf.h @@ -230,6 +230,9 @@ /* Define to 1 if you have the header file. */ #define HAVE_PWD_H 1 +/* Define to 1 if you have the `sched_getaffinity' function. */ +/* #undef HAVE_SCHED_GETAFFINITY */ + /* Define to 1 if you have the header file. */ #define HAVE_SCHED_H 1 diff --git a/ghc-lib/stage0/lib/ghcversion.h b/ghc-lib/stage0/lib/ghcversion.h --- a/ghc-lib/stage0/lib/ghcversion.h +++ b/ghc-lib/stage0/lib/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200430 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200601 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -925,7 +925,7 @@ freeReg 30 = False {- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively. For now we use r30 on 64 bit and r13 on 32 bit as a temporary register - in stack handling code. See compiler/nativeGen/PPC/Instr.hs. + in stack handling code. See compiler/GHC/CmmToAsm/PPC/Instr.hs. Later we might want to reserve r13 and r30 only where it is required. Then use r12 as temporary register, which is also what the C ABI does. diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h --- a/includes/stg/MachRegs.h +++ b/includes/stg/MachRegs.h @@ -341,7 +341,7 @@ The Sun SPARC register mapping !! IMPORTANT: if you change this register mapping you must also update - compiler/nativeGen/SPARC/Regs.hs. That file handles the + compiler/GHC/CmmToAsm/SPARC/Regs.hs. That file handles the mapping for the NCG. This one only affects via-c code. The SPARC register (window) story: Remember, within the Haskell diff --git a/libraries/ghc-boot/GHC/Settings/Platform.hs b/libraries/ghc-boot/GHC/Settings/Platform.hs --- a/libraries/ghc-boot/GHC/Settings/Platform.hs +++ b/libraries/ghc-boot/GHC/Settings/Platform.hs @@ -37,6 +37,7 @@ targetOS <- readSetting "target os" targetWordSize <- readSetting "target word size" targetWordBigEndian <- getBooleanSetting "target word big endian" + targetLeadingUnderscore <- getBooleanSetting "Leading underscore" targetUnregisterised <- getBooleanSetting "Unregisterised" targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" targetHasIdentDirective <- getBooleanSetting "target has .ident directive" @@ -55,6 +56,7 @@ , platformHasIdentDirective = targetHasIdentDirective , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols , platformIsCrossCompiling = crossCompiling + , platformLeadingUnderscore = targetLeadingUnderscore } ----------------------------------------------------------------------------- diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -6,7 +6,7 @@ -- Execute GHCi messages. -- -- For details on Remote GHCi, see Note [Remote GHCi] in --- compiler/ghci/GHCi.hs. +-- compiler/GHC/Runtime/Interpreter.hs. -- module GHCi.Run ( run, redirectInterrupts diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -85,8 +85,8 @@ Other Notes on TH / Remote GHCi - * Note [Remote GHCi] in compiler/ghci/GHCi.hs - * Note [External GHCi pointers] in compiler/ghci/GHCi.hs + * Note [Remote GHCi] in compiler/GHC/Runtime/Interpreter.hs + * Note [External GHCi pointers] in compiler/GHC/Runtime/Interpreter.hs * Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice -}