diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h --- a/compiler/CodeGen.Platform.h +++ b/compiler/CodeGen.Platform.h @@ -452,34 +452,34 @@ callerSaves BaseReg = True #endif #if defined(CALLER_SAVES_R1) -callerSaves (VanillaReg 1 _) = True +callerSaves (VanillaReg 1) = True #endif #if defined(CALLER_SAVES_R2) -callerSaves (VanillaReg 2 _) = True +callerSaves (VanillaReg 2) = True #endif #if defined(CALLER_SAVES_R3) -callerSaves (VanillaReg 3 _) = True +callerSaves (VanillaReg 3) = True #endif #if defined(CALLER_SAVES_R4) -callerSaves (VanillaReg 4 _) = True +callerSaves (VanillaReg 4) = True #endif #if defined(CALLER_SAVES_R5) -callerSaves (VanillaReg 5 _) = True +callerSaves (VanillaReg 5) = True #endif #if defined(CALLER_SAVES_R6) -callerSaves (VanillaReg 6 _) = True +callerSaves (VanillaReg 6) = True #endif #if defined(CALLER_SAVES_R7) -callerSaves (VanillaReg 7 _) = True +callerSaves (VanillaReg 7) = True #endif #if defined(CALLER_SAVES_R8) -callerSaves (VanillaReg 8 _) = True +callerSaves (VanillaReg 8) = True #endif #if defined(CALLER_SAVES_R9) -callerSaves (VanillaReg 9 _) = True +callerSaves (VanillaReg 9) = True #endif #if defined(CALLER_SAVES_R10) -callerSaves (VanillaReg 10 _) = True +callerSaves (VanillaReg 10) = True #endif #if defined(CALLER_SAVES_F1) callerSaves (FloatReg 1) = True @@ -555,34 +555,34 @@ ,Hp #endif #if defined(REG_R1) - ,VanillaReg 1 VGcPtr + ,VanillaReg 1 #endif #if defined(REG_R2) - ,VanillaReg 2 VGcPtr + ,VanillaReg 2 #endif #if defined(REG_R3) - ,VanillaReg 3 VGcPtr + ,VanillaReg 3 #endif #if defined(REG_R4) - ,VanillaReg 4 VGcPtr + ,VanillaReg 4 #endif #if defined(REG_R5) - ,VanillaReg 5 VGcPtr + ,VanillaReg 5 #endif #if defined(REG_R6) - ,VanillaReg 6 VGcPtr + ,VanillaReg 6 #endif #if defined(REG_R7) - ,VanillaReg 7 VGcPtr + ,VanillaReg 7 #endif #if defined(REG_R8) - ,VanillaReg 8 VGcPtr + ,VanillaReg 8 #endif #if defined(REG_R9) - ,VanillaReg 9 VGcPtr + ,VanillaReg 9 #endif #if defined(REG_R10) - ,VanillaReg 10 VGcPtr + ,VanillaReg 10 #endif #if defined(REG_SpLim) ,SpLim @@ -740,34 +740,34 @@ globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) # endif # if defined(REG_R1) -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) +globalRegMaybe (VanillaReg 1) = Just (RealRegSingle REG_R1) # endif # if defined(REG_R2) -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) +globalRegMaybe (VanillaReg 2) = Just (RealRegSingle REG_R2) # endif # if defined(REG_R3) -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) +globalRegMaybe (VanillaReg 3) = Just (RealRegSingle REG_R3) # endif # if defined(REG_R4) -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) +globalRegMaybe (VanillaReg 4) = Just (RealRegSingle REG_R4) # endif # if defined(REG_R5) -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) +globalRegMaybe (VanillaReg 5) = Just (RealRegSingle REG_R5) # endif # if defined(REG_R6) -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) +globalRegMaybe (VanillaReg 6) = Just (RealRegSingle REG_R6) # endif # if defined(REG_R7) -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) +globalRegMaybe (VanillaReg 7) = Just (RealRegSingle REG_R7) # endif # if defined(REG_R8) -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) +globalRegMaybe (VanillaReg 8) = Just (RealRegSingle REG_R8) # endif # if defined(REG_R9) -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) +globalRegMaybe (VanillaReg 9) = Just (RealRegSingle REG_R9) # endif # if defined(REG_R10) -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) +globalRegMaybe (VanillaReg 10) = Just (RealRegSingle REG_R10) # endif # if defined(REG_F1) globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} -- ----------------------------------------------------------------------------- @@ -316,6 +316,7 @@ import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make @@ -342,7 +343,7 @@ import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -353,11 +354,14 @@ import GHC.Utils.TmpFs import GHC.Utils.Error +import GHC.Utils.Exception import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +#if !defined(javascript_HOST_ARCH) import GHC.Utils.Panic.Plain +#endif import GHC.Utils.Logger import GHC.Utils.Fingerprint @@ -371,6 +375,8 @@ import GHC.Core.InstEnv import GHC.Core +import GHC.Data.Maybe + import GHC.Types.Id import GHC.Types.Name hiding ( varName ) import GHC.Types.Avail @@ -403,30 +409,27 @@ import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo +import Control.Applicative ((<|>)) +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch as MC import Data.Foldable +import Data.IORef +import Data.List (isPrefixOf) +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) + import qualified Data.Map.Strict as Map import Data.Set (Set) +import qualified Data.Set as S import qualified Data.Sequence as Seq -import Data.Maybe -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad + +import System.Directory +import System.Environment ( getEnv, getProgName ) import System.Exit ( exitWith, ExitCode(..) ) -import GHC.Utils.Exception -import Data.IORef import System.FilePath -import Control.Concurrent -import Control.Applicative ((<|>)) -import Control.Monad.Catch as MC - -import GHC.Data.Maybe import System.IO.Error ( isDoesNotExistError ) -import System.Environment ( getEnv, getProgName ) -import System.Directory -import Data.List (isPrefixOf) -import qualified Data.Set as S - -- %************************************************************************ -- %* * -- Initialisation: exception handlers @@ -558,13 +561,13 @@ initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir = setSession =<< liftIO ( do +#if !defined(javascript_HOST_ARCH) -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds. -- So we can't use assertM here. -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why. --- #if MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) !keep_cafs <- c_keepCAFsForGHCi massert keep_cafs --- #endif +#endif initHscEnv mb_top_dir ) @@ -675,8 +678,10 @@ logger <- getLogger -- Interpreter - interp <- if gopt Opt_ExternalInterpreter dflags - then do + interp <- if + -- external interpreter + | gopt Opt_ExternalInterpreter dflags + -> do let prog = pgm_i dflags ++ flavour profiled = ways dflags `hasWay` WayProf @@ -698,10 +703,31 @@ , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) , iservConfTrace = tr } - s <- liftIO $ newMVar IServPending + s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp conf (IServ s)) loader)) - else + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader)) + + -- JavaScript interpreter + | ArchJavaScript <- platformArch (targetPlatform dflags) + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + let cfg = JSInterpConfig + { jsInterpNodeConfig = defaultNodeJsSettings + , jsInterpScript = topDir dflags "ghc-interp.js" + , jsInterpTmpFs = hsc_tmpfs hsc_env + , jsInterpTmpDir = tmpDir dflags + , jsInterpLogger = hsc_logger hsc_env + , jsInterpCodegenCfg = initStgToJSConfig dflags + , jsInterpUnitEnv = hsc_unit_env hsc_env + , jsInterpFinderOpts = initFinderOpts dflags + , jsInterpFinderCache = hsc_FC hsc_env + } + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader)) + + -- Internal interpreter + | otherwise + -> #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader @@ -837,7 +863,7 @@ => Logger -> DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) + -> m (DynFlags, [Located String], Messages DriverMessage) parseDynamicFlags logger dflags cmdline = do (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline -- flags that have just been read are used by the logger when loading package @@ -939,7 +965,8 @@ let (dflags', warnings) = makeDynFlagsConsistent dflags let diag_opts = initDiagOpts dflags print_config = initPrintConfig dflags - liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings) + liftIO $ printOrThrowDiagnostics logger print_config diag_opts + $ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags @@ -1199,6 +1226,9 @@ details <- makeSimpleDetails lcl_logger tc_gbl_env safe <- finalSafeMode lcl_dflags tc_gbl_env + let !rdr_env = forceGlobalRdrEnv $ tcg_rdr_env tc_gbl_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -1209,7 +1239,7 @@ ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), + minf_rdr_env = Just rdr_env, minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details, minf_iface = Nothing, minf_safe = safe, @@ -1302,8 +1332,7 @@ else return $ Right mod_guts - Nothing -> panic "compileToCoreModule: target FilePath not found in\ - module dependency graph" + Nothing -> panic "compileToCoreModule: target FilePath not found in module dependency graph" where -- two versions, based on whether we simplify (thus run tidyProgram, -- which returns a (CgGuts, ModDetails) pair, or not (in which case -- we just have a ModGuts. @@ -1363,7 +1392,7 @@ data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_rdr_env :: Maybe IfGlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, minf_safe :: SafeHaskellMode, @@ -1389,40 +1418,45 @@ pte = eps_PTE eps tys = [ ty | name <- concatMap availNames avails, Just ty <- [lookupTypeEnv pte name] ] - -- + + let !rdr_env = availsToGlobalRdrEnv hsc_env mdl avails + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + return (Just (ModuleInfo { minf_type_env = mkTypeEnv tys, minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, + minf_rdr_env = Just rdr_env, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv -availsToGlobalRdrEnv mod_name avails - = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv +availsToGlobalRdrEnv hsc_env mod avails + = forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. where + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } - getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = case lookupHugByModule mdl (hsc_HUG hsc_env) of Nothing -> return Nothing Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi + let details = hm_details hmi + iface = hm_iface hmi return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, - minf_rdr_env = mi_globals $! hm_iface hmi, + minf_rdr_env = mi_globals $ hm_iface hmi, + -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. minf_instances = instEnvElts $ md_insts details, minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface @@ -1435,13 +1469,15 @@ modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] modInfoTopLevelScope minf - = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf) + = fmap (map greName . globalRdrEnvElts) (minf_rdr_env minf) + -- NB: no need to force this again. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = concatMap availNames $! minf_exports minf modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf -- | Returns the instances defined by the specified module. -- Warning: currently unimplemented for package modules. @@ -1471,7 +1507,7 @@ modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface -modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv +modInfoRdrEnv :: ModuleInfo -> Maybe IfGlobalRdrEnv modInfoRdrEnv = minf_rdr_env -- | Retrieve module safe haskell mode @@ -1482,7 +1518,9 @@ modInfoModBreaks = minf_modBreaks isDictonaryId :: Id -> Bool -isDictonaryId id = isDictTy (idType id) +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { + (_tvs, _theta, tau) -> isDictTy tau } -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use @@ -1957,7 +1995,8 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) --- -foreign import ccall unsafe "ghc_lib_parser_keepCAFsForGHCi" - c_keepCAFsForGHCi :: IO Bool +#if !defined(javascript_HOST_ARCH) +foreign import ccall unsafe "keepCAFsForGHCi" + c_keepCAFsForGHCi :: IO Bool +#endif 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 @@ -11,9 +11,9 @@ import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types import GHC.Types.Name( Name ) -import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) +import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) -import GHC.Types.Unique +import GHC.Types.Unique ( Unique ) import GHC.Builtin.Uniques import GHC.Data.FastString @@ -31,7 +31,8 @@ templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName, + mkNameLName, mkNameSName, mkNameQName, mkModNameName, liftStringName, @@ -109,8 +110,11 @@ -- TyVarBndr plainTVName, kindedTVName, plainInvisTVName, kindedInvisTVName, + plainBndrTVName, kindedBndrTVName, -- Specificity specifiedSpecName, inferredSpecName, + -- Visibility + bndrReqName, bndrInvisName, -- Role nominalRName, representationalRName, phantomRName, inferRName, -- Kind @@ -156,7 +160,9 @@ expQTyConName, fieldExpTyConName, predTyConName, stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, + typeTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName, + clauseTyConName, patQTyConName, funDepTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, codeTyConName, injAnnTyConName, kindTyConName, @@ -174,15 +180,20 @@ mkTHModule :: FastString -> Module mkTHModule m = mkModule thUnit (mkModuleNameFS m) -libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name +libFun, libTc, thFun, thTc, thCls, thCon :: FastString -> Unique -> Name libFun = mk_known_key_name varName thLib libTc = mk_known_key_name tcName thLib thFun = mk_known_key_name varName thSyn thTc = mk_known_key_name tcName thSyn thCls = mk_known_key_name clsName thSyn thCon = mk_known_key_name dataName thSyn -qqFun = mk_known_key_name varName qqLib +thFld :: FastString -> FastString -> Unique -> Name +thFld con = mk_known_key_name (fieldName con) thSyn + +qqFld :: FastString -> Unique -> Name +qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib + -------------------- TH.Syntax ----------------------- liftClassName :: Name liftClassName = thCls (fsLit "Lift") liftClassKey @@ -214,7 +225,7 @@ modNameTyConName = thTc (fsLit "ModName") modNameTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey @@ -227,11 +238,12 @@ mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey +unTypeName = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey @@ -492,11 +504,20 @@ plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey +plainBndrTVName, kindedBndrTVName :: Name +plainBndrTVName = libFun (fsLit "plainBndrTV") plainBndrTVIdKey +kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey + -- data Specificity = ... specifiedSpecName, inferredSpecName :: Name specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey +-- data BndrVis = ... +bndrReqName, bndrInvisName :: Name +bndrReqName = libFun (fsLit "bndrReq") bndrReqKey +bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey + -- data Role = ... nominalRName, representationalRName, phantomRName, inferRName :: Name nominalRName = libFun (fsLit "nominalR") nominalRIdKey @@ -569,7 +590,7 @@ varBangTypeTyConName, typeQTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, derivClauseTyConName, kindTyConName, - tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName, derivStrategyTyConName :: Name -- These are only used for the types of top-level splices expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -589,14 +610,15 @@ kindTyConName = thTc (fsLit "Kind") kindTyConKey tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey +tyVarBndrVisTyConName = libTc (fsLit "TyVarBndrVis") tyVarBndrVisTyConKey derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey +quoteExpName = qqFld (fsLit "quoteExp") quoteExpKey +quotePatName = qqFld (fsLit "quotePat") quotePatKey +quoteDecName = qqFld (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey -- data Inline = ... noInlineDataConName, inlineDataConName, inlinableDataConName :: Name @@ -652,7 +674,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, patTyConKey, stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, - tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, + tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, tyVarBndrVisTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, funDepTyConKey, predTyConKey, @@ -694,6 +716,7 @@ tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 codeTyConKey = mkPreludeTyConUnique 238 modNameTyConKey = mkPreludeTyConUnique 239 +tyVarBndrVisTyConKey = mkPreludeTyConUnique 240 {- ********************************************************************* * * @@ -741,7 +764,7 @@ -- If you want to change this, make sure you check in GHC.Builtin.Names returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 @@ -761,6 +784,7 @@ mkModNameIdKey = mkPreludeMiscIdUnique 215 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 mkNameQIdKey = mkPreludeMiscIdUnique 217 +mkNameG_fldIdKey = mkPreludeMiscIdUnique 218 -- data Lit = ... @@ -1022,6 +1046,10 @@ plainInvisTVIdKey = mkPreludeMiscIdUnique 482 kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 +plainBndrTVIdKey, kindedBndrTVIdKey :: Unique +plainBndrTVIdKey = mkPreludeMiscIdUnique 484 +kindedBndrTVIdKey = mkPreludeMiscIdUnique 485 + -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique nominalRIdKey = mkPreludeMiscIdUnique 416 @@ -1106,6 +1134,11 @@ specifiedSpecKey = mkPreludeMiscIdUnique 498 inferredSpecKey = mkPreludeMiscIdUnique 499 +-- data BndrVis = ... +bndrReqKey, bndrInvisKey :: Unique +bndrReqKey = mkPreludeMiscIdUnique 800 -- TODO (int-index): make up some room in the 5** numberspace? +bndrInvisKey = mkPreludeMiscIdUnique 801 + {- ************************************************************************ * * @@ -1114,12 +1147,14 @@ ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName +lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, mkNameG_fldRDR, + unsafeCodeCoerce_RDR :: RdrName lift_RDR = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName +mkNameG_fldRDR = nameRdrName mkNameG_fldName -- data Exp = ... conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs --- a/compiler/GHC/Builtin/Types/Literals.hs +++ b/compiler/GHC/Builtin/Types/Literals.hs @@ -479,8 +479,7 @@ axUnconsSymbolDef = mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $ - \str -> Just $ - mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str)) + \str -> Just $ computeUncons str axCharToNatDef = mkUnAxiom "CharToNatDef" typeCharToNatTyCon isCharLitTy $ @@ -784,14 +783,15 @@ mbY = isStrLitTy t matchFamConsSymbol _ = Nothing -reifyCharSymbolPairTy :: (Char, FastString) -> Type -reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s) +computeUncons :: FastString -> Type +computeUncons str = mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str)) + where reifyCharSymbolPairTy :: (Char, FastString) -> Type + reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s) matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamUnconsSymbol [s] | Just x <- mbX = - Just (axUnconsSymbolDef, [s] - , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS x))) + Just (axUnconsSymbolDef, [s], computeUncons x) where mbX = isStrLitTy s matchFamUnconsSymbol _ = Nothing 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 @@ -239,10 +239,10 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports - = map (avail . idName) ghcPrimIds ++ - map (avail . idName) allThePrimOpIds ++ - [ availTC n [n] [] - | tc <- exposedPrimTyCons, let n = tyConName tc ] + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName) allThePrimOpIds ++ + [ AvailTC n [n] + | tc <- exposedPrimTyCons, let n = tyConName tc ] ghcPrimDeclDocs :: Docs ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs } 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 @@ -22,11 +22,12 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHC.Runtime.Interpreter -import GHC.Runtime.Heap.Layout hiding ( WordOff ) +import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Literal +import GHC.Types.Unique import GHC.Types.Unique.DSet import GHC.Utils.Outputable @@ -198,8 +199,8 @@ -- this BCO to be long. (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm ((n_insns, lbl_map), long_jumps) - | isLarge (fromIntegral $ Map.size lbl_map0) - || isLarge n_insns0 + | isLargeW (fromIntegral $ Map.size lbl_map0) + || isLargeW n_insns0 = (inspectAsm platform True initial_offset asm, True) | otherwise = ((n_insns0, lbl_map0), False) @@ -228,7 +229,7 @@ return ul_bco -mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64 +mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64 -- Here the return type must be an array of Words, not StgWords, -- because the underlying ByteArray# will end up as a component -- of a BCO object. @@ -243,10 +244,22 @@ data Operand = Op Word + | IOp Int | SmallOp Word16 | LabelOp LocalLabel --- (unused) | LargeOp Word +wOp :: WordOff -> Operand +wOp = Op . fromIntegral + +bOp :: ByteOff -> Operand +bOp = Op . fromIntegral + +truncHalfWord :: Platform -> HalfWord -> Operand +truncHalfWord platform w = case platformWordSize platform of + PW4 | w <= 65535 -> Op (fromIntegral w) + PW8 | w <= 4294967295 -> Op (fromIntegral w) + _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w) + data Assembler a = AllocPtr (IO BCOPtr) (Word -> Assembler a) | AllocLit [BCONPtr] (Word -> Assembler a) @@ -286,9 +299,9 @@ largeOp :: Bool -> Operand -> Bool largeOp long_jumps op = case op of SmallOp _ -> False - Op w -> isLarge w + Op w -> isLargeW w + IOp i -> isLargeI i LabelOp _ -> long_jumps --- LargeOp _ -> True runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a runAsm platform long_jumps e = go @@ -307,15 +320,15 @@ go $ k w go (AllocLabel _ k) = go k go (Emit w ops k) = do - let largeOps = any (largeOp long_jumps) ops + let largeArgs = any (largeOp long_jumps) ops opcode - | largeOps = largeArgInstr w + | largeArgs = largeArgInstr w | otherwise = w words = concatMap expand ops expand (SmallOp w) = [w] expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeOps then largeArg platform (fromIntegral w) else [fromIntegral w] --- expand (LargeOp w) = largeArg platform w + expand (Op w) = if largeArgs then largeArg platform (fromIntegral w) else [fromIntegral w] + expand (IOp i) = if largeArgs then largeArg platform (fromIntegral i) else [fromIntegral i] state $ \(st_i0,st_l0,st_p0) -> let st_i1 = addListToSS st_i0 (opcode : words) in ((), (st_i1,st_l0,st_p0)) @@ -349,7 +362,7 @@ count (SmallOp _) = 1 count (LabelOp _) = count (Op 0) count (Op _) = if largeOps then largeArg16s platform else 1 --- count (LargeOp _) = largeArg16s platform + count (IOp _) = if largeOps then largeArg16s platform else 1 -- Bring in all the bci_ bytecode constants. #include "Bytecodes.h" @@ -378,15 +391,15 @@ -> Assembler () assembleI platform i = case i of STKCHECK n -> emit bci_STKCHECK [Op n] - PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] - PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] - PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] - PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1] - PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1] - PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1] - PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1] - PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1] - PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1] + PUSH_L o1 -> emit bci_PUSH_L [wOp o1] + PUSH_LL o1 o2 -> emit bci_PUSH_LL [wOp o1, wOp o2] + PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [wOp o1, wOp o2, wOp o3] + PUSH8 o1 -> emit bci_PUSH8 [bOp o1] + PUSH16 o1 -> emit bci_PUSH16 [bOp o1] + PUSH32 o1 -> emit bci_PUSH32 [bOp o1] + PUSH8_W o1 -> emit bci_PUSH8_W [bOp o1] + PUSH16_W o1 -> emit bci_PUSH16_W [bOp o1] + PUSH32_W o1 -> emit bci_PUSH32_W [bOp o1] PUSH_G nm -> do p <- ptr (BCOPtrName nm) emit bci_PUSH_G [Op p] PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) @@ -418,7 +431,7 @@ PUSH_UBX32 lit -> do np <- literal lit emit bci_PUSH_UBX32 [Op np] PUSH_UBX lit nws -> do np <- literal lit - emit bci_PUSH_UBX [Op np, SmallOp nws] + emit bci_PUSH_UBX [Op np, wOp nws] -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode PUSH_ADDR nm -> do np <- lit [BCONPtrAddr nm] @@ -436,15 +449,15 @@ PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] - SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] - ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] - ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] - ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] - MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] - MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] - UNPACK n -> emit bci_UNPACK [SmallOp n] + SLIDE n by -> emit bci_SLIDE [wOp n, wOp by] + ALLOC_AP n -> emit bci_ALLOC_AP [truncHalfWord platform n] + ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [truncHalfWord platform n] + ALLOC_PAP arity n -> emit bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n] + MKAP off sz -> emit bci_MKAP [wOp off, truncHalfWord platform sz] + MKPAP off sz -> emit bci_MKPAP [wOp off, truncHalfWord platform sz] + UNPACK n -> emit bci_UNPACK [wOp n] PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] - emit bci_PACK [Op itbl_no, SmallOp sz] + emit bci_PACK [Op itbl_no, wOp sz] LABEL lbl -> label lbl TESTLT_I i l -> do np <- int i emit bci_TESTLT_I [Op np, LabelOp l] @@ -497,19 +510,19 @@ TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] CASEFAIL -> emit bci_CASEFAIL [] - SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] + SWIZZLE stkoff n -> emit bci_SWIZZLE [wOp stkoff, IOp n] JMP l -> emit bci_JMP [LabelOp l] ENTER -> emit bci_ENTER [] RETURN rep -> emit (return_non_tuple rep) [] RETURN_TUPLE -> emit bci_RETURN_T [] CCALL off m_addr i -> do np <- addr m_addr - emit bci_CCALL [SmallOp off, Op np, SmallOp i] + emit bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit bci_PRIMCALL [] - BRK_FUN index mod cc -> do p1 <- ptr BCOPtrBreakArray - m <- addr mod + BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray + q <- int (getKey uniq) np <- addr cc emit bci_BRK_FUN [Op p1, SmallOp index, - Op m, Op np] + Op q, Op np] where literal (LitLabel fs (Just sz) _) @@ -555,8 +568,11 @@ words ws = lit (map BCONPtrWord ws) word w = words [w] -isLarge :: Word -> Bool -isLarge n = n > 65535 +isLargeW :: Word -> Bool +isLargeW n = n > 65535 + +isLargeI :: Int -> Bool +isLargeI n = n > 32767 || n < -32768 push_alts :: ArgRep -> Word16 push_alts V = bci_PUSH_ALTS_V 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006 @@ -18,10 +19,11 @@ import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name +import GHC.Types.Unique import GHC.Types.Literal import GHC.Core.DataCon import GHC.Builtin.PrimOps -import GHC.Runtime.Heap.Layout +import GHC.Runtime.Heap.Layout ( StgWord ) import Data.Int import Data.Word @@ -29,7 +31,6 @@ import GHC.Stack.CCS (CostCentre) import GHC.Stg.Syntax -import Language.Haskell.Syntax.Module.Name (ModuleName) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -40,7 +41,7 @@ protoBCOInstrs :: [BCInstr], -- instrs -- arity and GC info protoBCOBitmap :: [StgWord], - protoBCOBitmapSize :: Word16, + protoBCOBitmapSize :: Word, protoBCOArity :: Int, -- what the BCO came from, for debugging only protoBCOExpr :: Either [CgStgAlt] CgStgRhs, @@ -57,18 +58,18 @@ data BCInstr -- Messing with the stack - = STKCHECK Word + = STKCHECK !Word -- Push locals (existing bits of the stack) - | PUSH_L !Word16{-offset-} - | PUSH_LL !Word16 !Word16{-2 offsets-} - | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} + | PUSH_L !WordOff{-offset-} + | PUSH_LL !WordOff !WordOff{-2 offsets-} + | PUSH_LLL !WordOff !WordOff !WordOff{-3 offsets-} -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e., -- the stack will grow by 8, 16 or 32 bits) - | PUSH8 !Word16 - | PUSH16 !Word16 - | PUSH32 !Word16 + | PUSH8 !ByteOff + | PUSH16 !ByteOff + | PUSH32 !ByteOff -- Push the specified local as a 8, 16, 32 bit value onto the stack, but the -- value will take the whole word on the stack (i.e., the stack will grow by @@ -77,11 +78,11 @@ -- Currently we expect all values on the stack to take full words, except for -- the ones used for PACK (i.e., actually constructing new data types, in -- which case we use PUSH{8,16,32}) - | PUSH8_W !Word16 - | PUSH16_W !Word16 - | PUSH32_W !Word16 + | PUSH8_W !ByteOff + | PUSH16_W !ByteOff + | PUSH32_W !ByteOff - -- Push a (heap) ptr (these all map to PUSH_G really) + -- Push a ptr (these all map to PUSH_G really) | PUSH_G Name | PUSH_PRIMOP PrimOp | PUSH_BCO (ProtoBCO Name) @@ -101,8 +102,8 @@ | PUSH_UBX8 Literal | PUSH_UBX16 Literal | PUSH_UBX32 Literal - | PUSH_UBX Literal Word16 - -- push this int/float/double/addr, on the stack. Word16 + | PUSH_UBX Literal !WordOff + -- push this int/float/double/addr, on the stack. Word -- is # of words to copy from literal pool. Eitherness reflects -- the difficulty of dealing with MachAddr here, mostly due to -- the excessive (and unnecessary) restrictions imposed by the @@ -128,58 +129,61 @@ | PUSH_APPLY_PPPPP | PUSH_APPLY_PPPPPP - | SLIDE Word16{-this many-} Word16{-down by this much-} + | SLIDE !WordOff{-this many-} !WordOff{-down by this much-} -- To do with the heap - | ALLOC_AP !Word16 -- make an AP with this many payload words - | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words - | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words - | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} - | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} - | UNPACK !Word16 -- unpack N words from t.o.s Constr - | PACK DataCon !Word16 + | ALLOC_AP !HalfWord {- make an AP with this many payload words. + HalfWord matches the size of the n_args field in StgAP, + make sure that we handle truncation when generating + bytecode using this HalfWord type here -} + | ALLOC_AP_NOUPD !HalfWord -- make an AP_NOUPD with this many payload words + | ALLOC_PAP !HalfWord !HalfWord -- make a PAP with this arity / payload words + | MKAP !WordOff{-ptr to AP is this far down stack-} !HalfWord{-number of words-} + | MKPAP !WordOff{-ptr to PAP is this far down stack-} !HalfWord{-number of words-} + | UNPACK !WordOff -- unpack N words from t.o.s Constr + | PACK DataCon !WordOff -- after assembly, the DataCon is an index into the -- itbl array -- For doing case trees | LABEL LocalLabel - | TESTLT_I Int LocalLabel - | TESTEQ_I Int LocalLabel - | TESTLT_W Word LocalLabel - | TESTEQ_W Word LocalLabel - | TESTLT_I64 Int64 LocalLabel - | TESTEQ_I64 Int64 LocalLabel - | TESTLT_I32 Int32 LocalLabel - | TESTEQ_I32 Int32 LocalLabel - | TESTLT_I16 Int16 LocalLabel - | TESTEQ_I16 Int16 LocalLabel - | TESTLT_I8 Int8 LocalLabel - | TESTEQ_I8 Int16 LocalLabel - | TESTLT_W64 Word64 LocalLabel - | TESTEQ_W64 Word64 LocalLabel - | TESTLT_W32 Word32 LocalLabel - | TESTEQ_W32 Word32 LocalLabel - | TESTLT_W16 Word16 LocalLabel - | TESTEQ_W16 Word16 LocalLabel - | TESTLT_W8 Word8 LocalLabel - | TESTEQ_W8 Word8 LocalLabel - | TESTLT_F Float LocalLabel - | TESTEQ_F Float LocalLabel - | TESTLT_D Double LocalLabel - | TESTEQ_D Double LocalLabel + | TESTLT_I !Int LocalLabel + | TESTEQ_I !Int LocalLabel + | TESTLT_W !Word LocalLabel + | TESTEQ_W !Word LocalLabel + | TESTLT_I64 !Int64 LocalLabel + | TESTEQ_I64 !Int64 LocalLabel + | TESTLT_I32 !Int32 LocalLabel + | TESTEQ_I32 !Int32 LocalLabel + | TESTLT_I16 !Int16 LocalLabel + | TESTEQ_I16 !Int16 LocalLabel + | TESTLT_I8 !Int8 LocalLabel + | TESTEQ_I8 !Int16 LocalLabel + | TESTLT_W64 !Word64 LocalLabel + | TESTEQ_W64 !Word64 LocalLabel + | TESTLT_W32 !Word32 LocalLabel + | TESTEQ_W32 !Word32 LocalLabel + | TESTLT_W16 !Word16 LocalLabel + | TESTEQ_W16 !Word16 LocalLabel + | TESTLT_W8 !Word8 LocalLabel + | TESTEQ_W8 !Word8 LocalLabel + | TESTLT_F !Float LocalLabel + | TESTEQ_F !Float LocalLabel + | TESTLT_D !Double LocalLabel + | TESTEQ_D !Double LocalLabel -- The Word16 value is a constructor number and therefore -- stored in the insn stream rather than as an offset into -- the literal pool. - | TESTLT_P Word16 LocalLabel - | TESTEQ_P Word16 LocalLabel + | TESTLT_P !Word16 LocalLabel + | TESTEQ_P !Word16 LocalLabel | CASEFAIL | JMP LocalLabel -- For doing calls to C (via glue code generated by libffi) - | CCALL Word16 -- stack frame size + | CCALL !WordOff -- stack frame size (RemotePtr C_ffi_cif) -- addr of the glue code - Word16 -- flags. + !Word16 -- flags. -- -- 0x1: call is interruptible -- 0x2: call is unsafe @@ -190,8 +194,8 @@ | PRIMCALL -- For doing magic ByteArray passing to foreign calls - | SWIZZLE Word16 -- to the ptr N words down the stack, - Word16 -- add M (interpreted as a signed 16-bit entity) + | SWIZZLE !WordOff -- to the ptr N words down the stack, + !Int -- add M -- To Infinity And Beyond | ENTER @@ -201,7 +205,7 @@ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints - | BRK_FUN !Word16 (RemotePtr ModuleName) (RemotePtr CostCentre) + | BRK_FUN !Word16 Unique (RemotePtr CostCentre) -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -251,7 +255,7 @@ ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc -pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) = +pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body _typ) = hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ]) 4 (pprStgExprShort opts body) pprStgRhsShort opts rhs = pprStgRhs opts rhs @@ -352,7 +356,11 @@ ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN index _mod_name _cc) = text "BRK_FUN" <+> ppr index <+> text "" <+> text "" + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "" + where mb_uniq = sdocOption sdocSuppressUniques $ \case + True -> text "" + False -> ppr uniq + -- ----------------------------------------------------------------------------- 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 @@ -194,7 +194,7 @@ mod -> mod packagePart = encodeZ (unitFS pkgKey) modulePart = encodeZ (moduleNameFS modName) - occPart = encodeZ (occNameFS (nameOccName n)) + occPart = encodeZ $ occNameMangledFS (nameOccName n) label = concat [ if pkgKey == mainUnit then "" else packagePart ++ "_" diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -68,35 +68,33 @@ | isFloatType ty = float | otherwise = int where vec = case (w, regs) of - (W128, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) - (W256, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) - (W512, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) + (W128, AvailRegs vs fs ds ls (s:ss)) + | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), AvailRegs vs fs ds ls ss) + (W256, AvailRegs vs fs ds ls (s:ss)) + | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), AvailRegs vs fs ds ls ss) + (W512, AvailRegs vs fs ds ls (s:ss)) + | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) float = case (w, regs) of - (W32, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) - (W32, (vs, f:fs, ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) - (W64, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) - (W64, (vs, fs, d:ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) + (W32, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss) + (W32, AvailRegs vs (f:fs) ds ls ss) + | not passFloatInXmm -> k (RegisterParam f, AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (DoubleReg s), AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs (d:ds) ls ss) + | not passFloatInXmm -> k (RegisterParam d, AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) - (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform) - -> k (RegisterParam l, (vs, fs, ds, ls, ss)) + (_, AvailRegs (v:vs) fs ds ls ss) | widthInBits w <= widthInBits (wordWidth platform) + -> k (RegisterParam v, AvailRegs vs fs ds ls ss) + (_, AvailRegs vs fs ds (l:ls) ss) | widthInBits w > widthInBits (wordWidth platform) + -> k (RegisterParam l, AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty - !gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr passFloatInXmm = passFloatArgsInXmm platform passFloatArgsInXmm :: Platform -> Bool @@ -131,13 +129,24 @@ ----------------------------------------------------------------------------- -- Local information about the registers available -type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - , [Int] -- XMM (floats and doubles) - ) +-- | Keep track of locally available registers. +data AvailRegs + = AvailRegs + { availVanillaRegs :: [GlobalReg] + -- ^ Available vanilla registers + , availFloatRegs :: [GlobalReg] + -- ^ Available float registers + , availDoubleRegs :: [GlobalReg] + -- ^ Available double registers + , availLongRegs :: [GlobalReg] + -- ^ Available long registers + , availXMMRegs :: [Int] + -- ^ Available vector XMM registers + } +noAvailRegs :: AvailRegs +noAvailRegs = AvailRegs [] [] [] [] [] + -- Vanilla registers can contain pointers, Ints, Chars. -- Floats and doubles have separate register supplies. -- @@ -146,24 +155,26 @@ getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs getRegsWithoutNode platform = - ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform) - , realFloatRegs platform - , realDoubleRegs platform - , realLongRegs platform - , realXmmRegNos platform) + AvailRegs + { availVanillaRegs = filter (\r -> r /= node) (realVanillaRegs platform) + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } -- getRegsWithNode uses R1/node even if it isn't a register getRegsWithNode platform = - ( if null (realVanillaRegs platform) - then [VanillaReg 1] - else realVanillaRegs platform - , realFloatRegs platform - , realDoubleRegs platform - , realLongRegs platform - , realXmmRegNos platform) + AvailRegs + { availVanillaRegs = if null (realVanillaRegs platform) + then [VanillaReg 1] + else realVanillaRegs platform + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg] -allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] +allVanillaRegs :: Platform -> [GlobalReg] allXmmRegs :: Platform -> [Int] allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform)) @@ -173,7 +184,7 @@ allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform)) realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg] -realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] +realVanillaRegs :: Platform -> [GlobalReg] realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform)) realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform)) @@ -189,15 +200,16 @@ regList n = [1 .. n] allRegs :: Platform -> AvailRegs -allRegs platform = ( allVanillaRegs platform - , allFloatRegs platform - , allDoubleRegs platform - , allLongRegs platform - , allXmmRegs platform - ) +allRegs platform = + AvailRegs + { availVanillaRegs = allVanillaRegs platform + , availFloatRegs = allFloatRegs platform + , availDoubleRegs = allDoubleRegs platform + , availLongRegs = allLongRegs platform + , availXMMRegs = allXmmRegs platform } nodeOnly :: AvailRegs -nodeOnly = ([VanillaReg 1], [], [], [], []) +nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] } -- This returns the set of global registers that *cover* the machine registers -- used for argument passing. On platforms where registers can overlap---right @@ -207,18 +219,19 @@ realArgRegsCover :: Platform -> [GlobalReg] realArgRegsCover platform | passFloatArgsInXmm platform - = map ($ VGcPtr) (realVanillaRegs platform) ++ - realLongRegs platform ++ - realDoubleRegs platform -- we only need to save the low Double part of XMM registers. - -- Moreover, the NCG can't load/store full XMM - -- registers for now... + = realVanillaRegs platform ++ + realLongRegs platform ++ + realDoubleRegs platform + -- we only need to save the low Double part of XMM registers. + -- Moreover, the NCG can't load/store full XMM + -- registers for now... | otherwise - = map ($ VGcPtr) (realVanillaRegs platform) ++ - realFloatRegs platform ++ - realDoubleRegs platform ++ - realLongRegs platform - -- we don't save XMM registers if they are not used for parameter passing + = realVanillaRegs platform ++ + realFloatRegs platform ++ + realDoubleRegs platform ++ + realLongRegs platform + -- we don't save XMM registers if they are not used for parameter passing {- @@ -325,4 +338,4 @@ allArgRegsCover :: Platform -> [GlobalReg] allArgRegsCover platform = - nub (VanillaReg 1 VGcPtr : realArgRegsCover platform) + nub (VanillaReg 1 : realArgRegsCover platform) diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs --- a/compiler/GHC/Cmm/CommonBlockElim.hs +++ b/compiler/GHC/Cmm/CommonBlockElim.hs @@ -26,7 +26,6 @@ import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique -import GHC.Utils.Word64 (truncateWord64ToWord32) import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE @@ -183,10 +182,8 @@ cvt = fromInteger . toInteger - -- Since we are hashing, we can savely downcast Word64 to Word32 here. - -- Although a different hashing function may be more effective. hash_unique :: Uniquable a => a -> Word32 - hash_unique = truncateWord64ToWord32 . getKey . getUnique + hash_unique = cvt . getKey . getUnique -- | Ignore these node types for equality dont_care :: CmmNode O x -> Bool diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -39,7 +39,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Reg ( pprGlobalReg ) +import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) import GHC.Cmm.Utils import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module @@ -513,7 +513,7 @@ -- | Expressions, used for unwind information data UnwindExpr = UwConst !Int -- ^ literal value - | UwReg !GlobalReg !Int -- ^ register plus offset + | UwReg !GlobalRegUse !Int -- ^ register plus offset | UwDeref UnwindExpr -- ^ pointer dereferencing | UwLabel CLabel | UwPlus UnwindExpr UnwindExpr @@ -535,7 +535,7 @@ pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case UwConst i -> int i - UwReg g 0 -> pprGlobalReg g + UwReg g 0 -> pprGlobalRegUse g UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x)) UwDeref e -> char '*' <> pprUnwindExpr 3 env e UwLabel l -> pprAsmLabel env l diff --git a/compiler/GHC/Cmm/Dominators.hs b/compiler/GHC/Cmm/Dominators.hs --- a/compiler/GHC/Cmm/Dominators.hs +++ b/compiler/GHC/Cmm/Dominators.hs @@ -26,7 +26,8 @@ import Data.Foldable() import qualified Data.Tree as Tree -import Data.Word +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS import qualified GHC.CmmToAsm.CFG.Dominators as LT @@ -40,9 +41,6 @@ import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>)) import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Word64 (intToWord64) -import qualified GHC.Data.Word64Map as WM -import qualified GHC.Data.Word64Set as WS -- | =Dominator sets @@ -131,37 +129,33 @@ -- The implementation uses the Lengauer-Tarjan algorithm from the x86 -- back end. --- Technically, we do not need Word64 here, however the dominators code --- has to accomodate Word64 for other uses. - graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap where rpblocks = revPostorderFrom (graphMap g) (g_entry g) rplabels' = map entryLabel rpblocks - rplabels :: Array Word64 Label + rplabels :: Array Int Label rplabels = listArray bounds rplabels' rpmap :: LabelMap RPNum rpmap = mapFromList $ zipWith kvpair rpblocks [0..] where kvpair block i = (entryLabel block, RPNum i) - labelIndex :: Label -> Word64 + labelIndex :: Label -> Int labelIndex = flip findLabelIn imap - where imap :: LabelMap Word64 + where imap :: LabelMap Int imap = mapFromList $ zip rplabels' [0..] blockIndex = labelIndex . entryLabel - bounds :: (Word64, Word64) - bounds = (0, intToWord64 (length rpblocks - 1)) + bounds = (0, length rpblocks - 1) ltGraph :: [Block node C C] -> LT.Graph - ltGraph [] = WM.empty + ltGraph [] = IM.empty ltGraph (block:blocks) = - WM.insert + IM.insert (blockIndex block) - (WS.fromList $ map labelIndex $ successors block) + (IS.fromList $ map labelIndex $ successors block) (ltGraph blocks) - idom_array :: Array Word64 LT.Node + idom_array :: Array Int LT.Node idom_array = array bounds $ LT.idom (0, ltGraph rpblocks) domSet 0 = EntryNode diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -38,8 +38,8 @@ import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply -import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Panic ----------------------------------------------------------------------------- @@ -313,30 +313,36 @@ = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where platform = profilePlatform profile - -- See Note [Width of parameters] + + ci :: (LocalReg, ParamLocation) -> CmmNode O O ci (reg, RegisterParam r@(VanillaReg {})) = let local = CmmLocal reg - global = CmmReg (CmmGlobal r) - width = cmmRegWidth platform local - expr - | width == wordWidth platform = global - | width < wordWidth platform = - CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] - | otherwise = panic "Parameter width greater than word width" + width = cmmRegWidth local + (expr, ty) + -- See Note [Width of parameters] + | width == wordWidth platform + = (global, localRegType reg) + | width < wordWidth platform + = (CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] + ,setCmmTypeWidth (wordWidth platform) (localRegType reg)) + | otherwise + = panic "Parameter width greater than word width" + global = CmmReg (CmmGlobal $ GlobalRegUse r ty) in CmmAssign local expr -- Non VanillaRegs ci (reg, RegisterParam r) = - CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal $ GlobalRegUse r (localRegType reg))) ci (reg, StackParam off) | isBitsType $ localRegType reg + -- See Note [Width of parameters] , typeWidth (localRegType reg) < wordWidth platform = let stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned local = CmmLocal reg - width = cmmRegWidth platform local + width = cmmRegWidth local expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] in CmmAssign local expr @@ -376,25 +382,28 @@ platform = profilePlatform profile (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) - -- See Note [Width of parameters] + co :: (CmmExpr, ParamLocation) + -> ([GlobalReg], CmmAGraph) + -> ([GlobalReg], CmmAGraph) co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = let width = cmmExprWidth platform v value + -- See Note [Width of parameters] | width == wordWidth platform = v | width < wordWidth platform = CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v] | otherwise = panic "Parameter width greater than word width" - in (r:rs, mkAssign (CmmGlobal r) value <*> ms) + in (r:rs, mkAssign (CmmGlobal $ GlobalRegUse r (cmmExprType platform value)) value <*> ms) -- Non VanillaRegs co (v, RegisterParam r) (rs, ms) = - (r:rs, mkAssign (CmmGlobal r) v <*> ms) + (r:rs, mkAssign (CmmGlobal $ GlobalRegUse r (cmmExprType platform v)) v <*> ms) - -- See Note [Width of parameters] co (v, StackParam off) (rs, ms) = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) + -- See Note [Width of parameters] width v = cmmExprWidth platform v value v | isBitsType $ cmmExprType platform v @@ -427,19 +436,18 @@ -- Note [Width of parameters] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing: --- * Global registers are considered to have native word width (i.e., 64-bits on --- x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a --- global register. --- * Same problem exists with LLVM IR. --- * Lowering gets harder since on x86-32 not every register exposes its lower +-- * Lowering gets harder, since on x86-32 not every register exposes its lower -- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding -- 8-bit register for %edi). So we would either need to extend/narrow anyway, -- or complicate the calling convention. -- * Passing a small integer in a stack slot, which has native word width, -- requires extending to word width when writing to the stack and narrowing -- when reading off the stack (see #16258). +-- This is because the generated Cmm application functions (such as stg_ap_n) +-- always load the full width from the stack. -- So instead, we always extend every parameter smaller than native word width -- in copyOutOflow and then truncate it back to the expected width in copyIn. -- Note that we do this in cmm using MO_XX_Conv to avoid requiring diff --git a/compiler/GHC/Cmm/LRegSet.hs b/compiler/GHC/Cmm/LRegSet.hs --- a/compiler/GHC/Cmm/LRegSet.hs +++ b/compiler/GHC/Cmm/LRegSet.hs @@ -20,35 +20,34 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Cmm.Expr -import GHC.Word -import GHC.Data.Word64Set as Word64Set +import Data.IntSet as IntSet -- Compact sets for membership tests of local variables. -type LRegSet = Word64Set.Word64Set -type LRegKey = Word64 +type LRegSet = IntSet.IntSet +type LRegKey = Int emptyLRegSet :: LRegSet -emptyLRegSet = Word64Set.empty +emptyLRegSet = IntSet.empty nullLRegSet :: LRegSet -> Bool -nullLRegSet = Word64Set.null +nullLRegSet = IntSet.null insertLRegSet :: LocalReg -> LRegSet -> LRegSet -insertLRegSet l = Word64Set.insert (getKey (getUnique l)) +insertLRegSet l = IntSet.insert (getKey (getUnique l)) elemLRegSet :: LocalReg -> LRegSet -> Bool -elemLRegSet l = Word64Set.member (getKey (getUnique l)) +elemLRegSet l = IntSet.member (getKey (getUnique l)) deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet -deleteFromLRegSet set reg = Word64Set.delete (getKey . getUnique $ reg) set +deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set -sizeLRegSet :: Word64Set -> Int -sizeLRegSet = Word64Set.size +sizeLRegSet :: IntSet -> Int +sizeLRegSet = IntSet.size -plusLRegSet :: Word64Set -> Word64Set -> Word64Set -plusLRegSet = Word64Set.union +plusLRegSet :: IntSet -> IntSet -> IntSet +plusLRegSet = IntSet.union -elemsLRegSet :: Word64Set -> [Word64] -elemsLRegSet = Word64Set.toList +elemsLRegSet :: IntSet -> [Int] +elemsLRegSet = IntSet.toList 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 @@ -350,7 +350,7 @@ -- Not foolproof, but GCFun is the culprit we most want to catch isGcJump :: CmmNode O C -> Bool -isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) +isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal (GlobalRegUse l _)) }) = l == GCFun || l == GCEnter1 isGcJump _something_else = False @@ -875,7 +875,7 @@ do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg adj block | sp_off /= 0 - = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off) + = block `blockSnoc` CmmAssign (spReg platform) (cmmOffset platform (spExpr platform) sp_off) | otherwise = block -- Add unwind pseudo-instruction at the beginning of each block to -- document Sp level for debugging @@ -884,7 +884,7 @@ = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block | otherwise = block - where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform) + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform) -- Add unwind pseudo-instruction right after the Sp adjustment -- if there is one. @@ -894,7 +894,7 @@ = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] | otherwise = block - where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off) + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform - sp_off) {- Note [SP old/young offsets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -917,7 +917,7 @@ areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) - = cmmOffset platform spExpr (sp_old - area_off area - n) + = cmmOffset platform (spExpr platform) (sp_old - area_off area - n) -- Replace (CmmStackSlot area n) with an offset from Sp areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) @@ -939,9 +939,9 @@ -- | Determine whether a stack check cannot fail. falseStackCheck :: [CmmExpr] -> Bool falseStackCheck [ CmmMachOp (MO_Sub _) - [ CmmRegOff (CmmGlobal Sp) x_off + [ CmmRegOff (CmmGlobal (GlobalRegUse Sp _)) x_off , CmmLit (CmmInt y_lit _)] - , CmmReg (CmmGlobal SpLim)] + , CmmReg (CmmGlobal (GlobalRegUse SpLim _))] = fromIntegral x_off >= y_lit falseStackCheck _ = False @@ -1087,7 +1087,7 @@ [ CmmAssign (CmmLocal reg) -- This cmmOffset basically corresponds to manifesting -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] - (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off)) + (CmmLoad (cmmOffset platform (spExpr platform) (sp_off - reg_off)) (localRegType reg) NaturallyAligned) | (reg, reg_off) <- stackSlotRegs stackmap @@ -1142,7 +1142,7 @@ -- Both 'id' and 'new_base' are KindNonPtr because they're -- RTS-only objects and are not subject to garbage collection id <- newTemp (bWord platform) - new_base <- newTemp (cmmRegType platform baseReg) + new_base <- newTemp (cmmRegType $ baseReg platform) let (caller_save, caller_load) = callerSaveVolatileRegs platform save_state_code <- saveThreadState profile load_state_code <- loadThreadState profile @@ -1153,7 +1153,7 @@ resume = mkMiddle (callResumeThread new_base id) <*> -- Assign the result to BaseReg: we -- might now have a different Capability! - mkAssign baseReg (CmmReg (CmmLocal new_base)) <*> + mkAssign (baseReg platform) (CmmReg (CmmLocal new_base)) <*> caller_load <*> load_state_code @@ -1168,7 +1168,7 @@ -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. jump = CmmCall { cml_target = entryCode platform $ - cmmLoadBWord platform spExpr + cmmLoadBWord platform (spExpr platform) , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes (wordWidth platform) @@ -1193,7 +1193,7 @@ callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl = CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) - [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)] + [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -28,6 +28,7 @@ import GHC.Parser.CharClass import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () +import GHC.Platform import GHC.Utils.Error import GHC.Utils.Misc --import TRACE @@ -103,22 +104,22 @@ "False" { kw CmmT_False } "likely" { kw CmmT_likely} - P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } - R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } - F@decimal { global_regN FloatReg } - D@decimal { global_regN DoubleReg } - L@decimal { global_regN LongReg } - Sp { global_reg Sp } - SpLim { global_reg SpLim } - Hp { global_reg Hp } - HpLim { global_reg HpLim } - CCCS { global_reg CCCS } - CurrentTSO { global_reg CurrentTSO } - CurrentNursery { global_reg CurrentNursery } - HpAlloc { global_reg HpAlloc } - BaseReg { global_reg BaseReg } - MachSp { global_reg MachSp } - UnwindReturnReg { global_reg UnwindReturnReg } + P@decimal { global_regN VanillaReg gcWord } + R@decimal { global_regN VanillaReg bWord } + F@decimal { global_regN FloatReg (const $ cmmFloat W32) } + D@decimal { global_regN DoubleReg (const $ cmmFloat W64) } + L@decimal { global_regN LongReg (const $ cmmBits W64) } + Sp { global_reg Sp bWord } + SpLim { global_reg SpLim bWord } + Hp { global_reg Hp gcWord } + HpLim { global_reg HpLim bWord } + CCCS { global_reg CCCS bWord } + CurrentTSO { global_reg CurrentTSO bWord } + CurrentNursery { global_reg CurrentNursery bWord } + HpAlloc { global_reg HpAlloc bWord } + BaseReg { global_reg BaseReg bWord } + MachSp { global_reg MachSp bWord } + UnwindReturnReg { global_reg UnwindReturnReg bWord } $namebegin $namechar* { name } @@ -178,7 +179,7 @@ | CmmT_float32 | CmmT_float64 | CmmT_gcptr - | CmmT_GlobalReg GlobalReg + | CmmT_GlobalReg GlobalRegUse | CmmT_Name FastString | CmmT_String String | CmmT_Int Integer @@ -210,14 +211,20 @@ kw :: CmmToken -> Action kw tok span _buf _len = return (L span tok) -global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len - = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) +global_regN :: (Int -> GlobalReg) -> (Platform -> CmmType) -> Action +global_regN con ty_fn span buf len + = do { platform <- getPlatform + ; let reg = con (fromIntegral n) + ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } where buf' = stepOn buf n = parseUnsignedInteger buf' (len-1) 10 octDecDigit -global_reg :: GlobalReg -> Action -global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) +global_reg :: GlobalReg -> (Platform -> CmmType) -> Action +global_reg reg ty_fn span _buf _len + = do { platform <- getPlatform + ; let ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } strtoken :: (String -> CmmToken) -> Action strtoken f span buf len = diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -107,8 +107,7 @@ then cmmCheckMachOp op args tys else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op) lintCmmExpr (CmmRegOff reg offset) - = do platform <- getPlatform - let rep = typeWidth (cmmRegType platform reg) + = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) lintCmmExpr expr = @@ -171,24 +170,10 @@ CmmUnwind{} -> return () CmmAssign reg expr -> do - platform <- getPlatform erep <- lintCmmExpr expr - let reg_ty = cmmRegType platform reg - unless (compat_regs erep reg_ty) $ + let reg_ty = cmmRegType reg + unless (erep `cmmEqType_ignoring_ptrhood` reg_ty) $ cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - where - compat_regs :: CmmType -> CmmType -> Bool - compat_regs ty1 ty2 - -- As noted in #22297, SIMD vector registers can be used for - -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats, - -- or 4 Int32s, or 2 Word64s, ... - -- To allow this, we relax the check: we only ensure that the widths - -- match, until we can find a more robust solution. - | isVecType ty1 - , isVecType ty2 - = typeWidth ty1 == typeWidth ty2 - | otherwise - = cmmEqType_ignoring_ptrhood ty1 ty2 CmmStore l r _alignment -> do _ <- lintCmmExpr l 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 @@ -213,33 +213,23 @@ = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can. We don't perform this optimization if rep is greater --- than the host word size because we use an Int to store the offset. See --- #24893 and #24700. This should be fixed to ensure that optimizations don't --- depend on the compiler host platform. +-- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] - | validOffsetRep rep = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - | validOffsetRep rep = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] - | validOffsetRep rep = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - | validOffsetRep rep = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] - | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] - | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] - | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) @@ -420,13 +410,6 @@ cmmMachOpFoldM _ _ _ = Nothing --- | Check that a literal width is compatible with the host word size used to --- store offsets. This should be fixed properly (using larger types to store --- literal offsets). See #24893 -validOffsetRep :: Width -> Bool -validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) - - {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have @@ -442,5 +425,5 @@ -- Utils isPicReg :: CmmExpr -> Bool -isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True +isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False 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 @@ -375,11 +375,11 @@ 'float64' { L _ (CmmT_float64) } 'gcptr' { L _ (CmmT_gcptr) } - GLOBALREG { L _ (CmmT_GlobalReg $$) } - NAME { L _ (CmmT_Name $$) } - STRING { L _ (CmmT_String $$) } - INT { L _ (CmmT_Int $$) } - FLOAT { L _ (CmmT_Float $$) } + GLOBALREG { L _ (CmmT_GlobalReg $$) } + NAME { L _ (CmmT_Name $$) } + STRING { L _ (CmmT_String $$) } + INT { L _ (CmmT_Int $$) } + FLOAT { L _ (CmmT_Float $$) } %monad { PD } { >>= } { return } %lexer { cmmlex } { L _ CmmT_EOF } @@ -714,9 +714,9 @@ unwind_regs :: { CmmParse [(GlobalReg, Maybe CmmExpr)] } : GLOBALREG '=' expr_or_unknown ',' unwind_regs - { do e <- $3; rest <- $5; return (($1, e) : rest) } + { do e <- $3; rest <- $5; return ((globalRegUseGlobalReg $1, e) : rest) } | GLOBALREG '=' expr_or_unknown - { do e <- $3; return [($1, e)] } + { do e <- $3; return [(globalRegUseGlobalReg $1, e)] } -- | A memory ordering mem_ordering :: { CmmParse MemoryOrdering } @@ -763,9 +763,9 @@ ; return (realArgRegsCover platform) } -- All of them. See comment attached -- to realArgRegsCover - | '[' globals ']' { $2 } + | '[' globals ']' { map globalRegUseGlobalReg $2 } -globals :: { [GlobalReg] } +globals :: { [GlobalRegUse] } : GLOBALREG { [$1] } | GLOBALREG ',' globals { $1 : $3 } @@ -1009,7 +1009,7 @@ ( "eq", MO_Eq ), ( "ne", MO_Ne ), ( "mul", MO_Mul ), - ( "mulmayoflo", MO_S_MulMayOflo ), + ( "mulmayoflo", MO_S_MulMayOflo ), ( "neg", MO_S_Neg ), ( "quot", MO_S_Quot ), ( "rem", MO_S_Rem ), @@ -1040,6 +1040,11 @@ ( "fmul", MO_F_Mul ), ( "fquot", MO_F_Quot ), + ( "fmadd" , MO_FMA FMAdd ), + ( "fmsub" , MO_FMA FMSub ), + ( "fnmadd", MO_FMA FNMAdd ), + ( "fnmsub", MO_FMA FNMSub ), + ( "feq", MO_F_Eq ), ( "fne", MO_F_Ne ), ( "fge", MO_F_Ge ), @@ -1137,6 +1142,12 @@ , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst) , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease) , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst) + , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add) + , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub) + , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And) + , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand) + , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or) + , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor) ] where allWidths @@ -1177,19 +1188,30 @@ -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint -inferCmmHint (CmmLit (CmmLabel _)) = AddrHint -inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint -inferCmmHint _ = NoHint +inferCmmHint (CmmLit (CmmLabel _)) + = AddrHint +inferCmmHint (CmmReg (CmmGlobal reg)) + | isPtrGlobalRegUse reg + = AddrHint +inferCmmHint _ + = NoHint -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CCCS = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = False +isPtrGlobalRegUse :: GlobalRegUse -> Bool +isPtrGlobalRegUse (GlobalRegUse reg ty) + | VanillaReg {} <- reg + , isGcPtrType ty + = True + | otherwise + = go reg + where + go Sp = True + go SpLim = True + go Hp = True + go HpLim = True + go CCCS = True + go CurrentTSO = True + go CurrentNursery = True + go _ = False happyError :: PD a happyError = PD $ \_ _ s -> unP srcParseFail s @@ -1479,7 +1501,7 @@ withSourceNote a b parse = do name <- getName case combineSrcSpans (getLoc a) (getLoc b) of - RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse + RealSrcSpan span _ -> code (emitTick (SourceNote span $ LexicalFastString $ mkFastString name)) >> parse _other -> parse -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Reducibility.hs b/compiler/GHC/Cmm/Reducibility.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Cmm/Reducibility.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module : GHC.Cmm.Reducibility +Description : Tell if a `CmmGraph` is reducible, or make it so + +Test a Cmm control-flow graph for reducibility. And provide a +function that, when given an arbitrary control-flow graph, returns an +equivalent, reducible control-flow graph. The equivalent graph is +obtained by "splitting" (copying) nodes of the original graph. +The resulting equivalent graph has the same dynamic behavior as the +original, but it is larger. + +Documentation uses the language of control-flow analysis, in which a +basic block is called a "node." These "nodes" are `CmmBlock`s or +equivalent; they have nothing to do with a `CmmNode`. + +For more on reducibility and related analyses and algorithms, see +Note [Reducibility resources] +-} + +module GHC.Cmm.Reducibility + ( Reducibility(..) + , reducibility + + , asReducible + ) +where + +import GHC.Prelude hiding (splitAt, succ) + +import Control.Monad +import Data.List (nub) +import Data.Maybe +import Data.Semigroup +import qualified Data.Sequence as Seq + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dominators +import GHC.Cmm.Dataflow.Graph hiding (addBlock) +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Collapse +import GHC.Data.Graph.Inductive.Graph +import GHC.Data.Graph.Inductive.PatriciaTree +import GHC.Types.Unique.Supply +import GHC.Utils.Panic + +-- | Represents the result of a reducibility analysis. +data Reducibility = Reducible | Irreducible + deriving (Eq, Show) + +-- | Given a graph, say whether the graph is reducible. The graph must +-- be bundled with a dominator analysis and a reverse postorder +-- numbering, as these results are needed to perform the test. + +reducibility :: NonLocal node + => GraphWithDominators node + -> Reducibility +reducibility gwd = + if all goodBlock blockmap then Reducible else Irreducible + where goodBlock b = all (goodEdge (entryLabel b)) (successors b) + goodEdge from to = rpnum to > rpnum from || to `dominates` from + rpnum = gwdRPNumber gwd + blockmap = graphMap $ gwd_graph gwd + dominators = gwdDominatorsOf gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (dominators blockname) + +-- | Given a graph, return an equivalent reducible graph, by +-- "splitting" (copying) nodes if necessary. The input +-- graph must be bundled with a dominator analysis and a reverse +-- postorder numbering. The computation is monadic because when a +-- node is split, the new copy needs a fresh label. +-- +-- Use this function whenever a downstream algorithm needs a reducible +-- control-flow graph. + +asReducible :: GraphWithDominators CmmNode + -> UniqSM (GraphWithDominators CmmNode) +asReducible gwd = case reducibility gwd of + Reducible -> return gwd + Irreducible -> assertReducible <$> nodeSplit gwd + +assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode +assertReducible gwd = case reducibility gwd of + Reducible -> gwd + Irreducible -> panic "result not reducible" + +---------------------------------------------------------------- + +-- | Split one or more nodes of the given graph, which must be +-- irreducible. + +nodeSplit :: GraphWithDominators CmmNode + -> UniqSM (GraphWithDominators CmmNode) +nodeSplit gwd = + graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed + where g = gwd_graph gwd + collapsed :: NullCollapseViz (Gr CmmSuper ()) + collapsed = collapseInductiveGraph (cgraphOfCmm g) + +type CGraph = Gr CmmSuper () + +-- | Turn a collapsed supernode back into a control-flow graph +inflate :: Label -> CGraph -> CmmGraph +inflate entry cg = CmmGraph entry graph + where graph = GMany NothingO body NothingO + body :: LabelMap CmmBlock + body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $ + blocks super + super = case labNodes cg of + [(_, s)] -> s + _ -> panic "graph given to `inflate` is not singleton" + + +-- | Convert a `CmmGraph` into an inductive graph. +-- (The function coalesces duplicate edges into a single edge.) +cgraphOfCmm :: CmmGraph -> CGraph +cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks + where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g) + cnodes = [(k, super block) | (k, block) <- blocks] + where super block = Nodes (entryLabel block) (Seq.singleton block) + labelNumber = \lbl -> fromJust $ mapLookup lbl numbers + where numbers :: LabelMap Int + numbers = mapFromList $ map swap blocks + swap (k, block) = (entryLabel block, k) + addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph + addSuccEdges graph (k, block) = + insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph +{- +Note [Reducibility resources] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977. +Available to borrow from archive.org. + +Matthew S. Hecht and Jeffrey D. Ullman (1972). +Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +https://doi.org/10.1137/0201014 + +Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with +controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997), +1031–1052. DOI:https://doi.org/10.1145/267959.269971 + +Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops: +optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July +2002), 299–333. https://doi.org/10.1145/567097.567098. (This one +contains the most detailed account of how the Hecht/Ullman algorithm +is used to modify an actual control-flow graph. But still not much detail.) + +https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html + (Nice summary of useful facts) + +-} + + + +type Seq = Seq.Seq + +-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph. +-- The entry point is the given label, and the block with that label +-- dominates all the other blocks in the supernode. When an entire +-- graph is collapsed into a single supernode, the graph is reducible. +-- More detail can be found in "GHC.Data.Graph.Collapse". + +data CmmSuper + = Nodes { label :: Label + , blocks :: Seq CmmBlock + } + +instance Semigroup CmmSuper where + s <> s' = Nodes (label s) (blocks s <> blocks s') + +instance PureSupernode CmmSuper where + superLabel = label + mapLabels = changeLabels + +instance Supernode CmmSuper NullCollapseViz where + freshen s = liftUniqSM $ relabel s + + +-- | Return all labels defined within a supernode. +definedLabels :: CmmSuper -> Seq Label +definedLabels = fmap entryLabel . blocks + + + +-- | Map the given function over every use and definition of a label +-- in the given supernode. +changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper) +changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks) + +-- | Map the given function over every use and definition of a label +-- in the given block. +changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock +changeBlockLabels f block = blockJoin entry' middle exit' + where (entry, middle, exit) = blockSplit block + entry' = let CmmEntry l scope = entry + in CmmEntry (f l) scope + exit' = case exit of + -- unclear why mapSuccessors doesn't touch these + CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) } + CmmForeignCall { succ = l } -> exit { succ = f l } + _ -> mapSuccessors f exit + + +-- | Within the given supernode, replace every defined label (and all +-- of its uses) with a fresh label. + +relabel :: CmmSuper -> UniqSM CmmSuper +relabel node = do + finite_map <- foldM addPair mapEmpty $ definedLabels node + return $ changeLabels (labelChanger finite_map) node + where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label) + addPair map old = do new <- newBlockId + return $ mapInsert old new map + labelChanger :: LabelMap Label -> (Label -> Label) + labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -21,7 +21,7 @@ import GHC.Platform import GHC.Types.Unique.FM -import qualified GHC.Data.Word64Set as Word64Set +import qualified Data.IntSet as IntSet import Data.List (partition) import Data.Maybe @@ -175,7 +175,7 @@ -- Annotate the middle nodes with the registers live *after* -- the node. This will help us decide whether we can inline -- an assignment in the current node or not. - live = Word64Set.unions (map getLive succs) + live = IntSet.unions (map getLive succs) live_middle = gen_killL platform last live ann_middles = annotate platform live_middle (blockToList middle) @@ -188,7 +188,7 @@ -- one predecessor), so identify the join points and the set -- of registers live in them. (joins, nonjoins) = partition (`mapMember` join_pts) succs - live_in_joins = Word64Set.unions (map getLive joins) + live_in_joins = IntSet.unions (map getLive joins) -- We do not want to sink an assignment into multiple branches, -- so identify the set of registers live in multiple successors. @@ -215,7 +215,7 @@ live_sets' | should_drop = live_sets | otherwise = map upd live_sets - upd set | r `elemLRegSet` set = set `Word64Set.union` live_rhs + upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs | otherwise = set live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs @@ -244,7 +244,7 @@ -- isTrivial :: Platform -> CmmExpr -> Bool isTrivial _ (CmmReg (CmmLocal _)) = True -isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] +isTrivial platform (CmmReg (CmmGlobal (GlobalRegUse r _))) = -- see Note [Inline GlobalRegs?] if isARM (platformArch platform) then True -- CodeGen.Platform.ARM does not have globalRegMaybe else isJust (globalRegMaybe platform r) @@ -667,9 +667,9 @@ , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively - | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True - | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + | HeapMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Hp _)) _ <- node = True + | StackMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True + | SpMem{} <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True @@ -703,9 +703,9 @@ -- Cmm expression globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node = - -- See Note [Inlining foldRegsDefd] - inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr) - False node + -- See Note [Inlining foldRegsDefd] + inline foldRegsDefd platform (\b r -> b || globalRegUsedIn platform r expr) + False node -- Returns True if node defines any local registers that are used in the -- Cmm expression @@ -852,17 +852,17 @@ loadAddr :: Platform -> CmmExpr -> Width -> AbsMem loadAddr platform e w = case e of - CmmReg r -> regAddr platform r 0 w - CmmRegOff r i -> regAddr platform r i w - _other | regUsedIn platform spReg e -> StackMem - | otherwise -> AnyMem + CmmReg r -> regAddr r 0 w + CmmRegOff r i -> regAddr r i w + _other | regUsedIn platform (spReg platform) e -> StackMem + | otherwise -> AnyMem -regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem -regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr _ (CmmGlobal Hp) _ _ = HeapMem -regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps -regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ _ = AnyMem +regAddr :: CmmReg -> Int -> Width -> AbsMem +regAddr (CmmGlobal (GlobalRegUse Sp _)) i w = SpMem i (widthInBytes w) +regAddr (CmmGlobal (GlobalRegUse Hp _)) _ _ = HeapMem +regAddr (CmmGlobal (GlobalRegUse CurrentTSO _)) _ _ = HeapMem -- important for PrimOps +regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ = AnyMem {- Note [Inline GlobalRegs?] diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs --- a/compiler/GHC/Cmm/ThreadSanitizer.hs +++ b/compiler/GHC/Cmm/ThreadSanitizer.hs @@ -54,11 +54,13 @@ CmmTick{} -> BMiddle node CmmUnwind{} -> BMiddle node CmmAssign{} -> annotateNodeOO env node - CmmStore lhs rhs align -> + -- TODO: Track unaligned stores + CmmStore _ _ Unaligned -> annotateNodeOO env node + CmmStore lhs rhs NaturallyAligned -> let ty = cmmExprType (platform env) rhs rhs_nodes = annotateLoads env (collectExprLoads rhs) lhs_nodes = annotateLoads env (collectExprLoads lhs) - st = tsanStore env align ty lhs + st = tsanStore env ty lhs in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node CmmUnsafeForeignCall (PrimTarget op) formals args -> let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args) @@ -156,17 +158,23 @@ regs = filter (callerSaves platform) (activeStgRegs platform) save = blockFromList (map saveReg regs) + + saveReg :: GlobalReg -> CmmNode O O saveReg reg = CmmStore (get_GlobalReg_addr platform reg) - (CmmReg (CmmGlobal reg)) + (CmmReg (CmmGlobal (GlobalRegUse reg ty))) NaturallyAligned + where ty = globalRegSpillType platform reg restore = blockFromList (map restoreReg regs) + + restoreReg :: GlobalReg -> CmmNode O O restoreReg reg = - CmmAssign (CmmGlobal reg) + CmmAssign (CmmGlobal (GlobalRegUse reg ty)) (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType platform reg) + ty NaturallyAligned) + where ty = globalRegSpillType platform reg -- | Mirrors __tsan_memory_order -- @@ -191,17 +199,14 @@ lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction tsanStore :: Env - -> AlignmentSpec -> CmmType -> CmmExpr + -> CmmType -> CmmExpr -> Block CmmNode O O -tsanStore env align ty addr = +tsanStore env ty addr = mkUnsafeCall env ftarget [] [addr] where ftarget = tsanTarget fn [] [AddrHint] w = widthInBytes (typeWidth ty) - fn = case align of - Unaligned - | w > 1 -> fsLit $ "__tsan_unaligned_write" ++ show w - _ -> fsLit $ "__tsan_write" ++ show w + fn = fsLit $ "__tsan_write" ++ show w tsanLoad :: Env -> AlignmentSpec -> CmmType -> CmmExpr 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 @@ -50,7 +50,7 @@ cmmConstrTag1, mAX_PTR_TAG, tAG_MASK, -- Overlap and usage - regsOverlap, regUsedIn, + regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn, -- Liveness and bitmaps mkLiveness, @@ -98,8 +98,7 @@ primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case VoidRep -> panic "primRepCmmType:VoidRep" - LiftedRep -> gcWord platform - UnliftedRep -> gcWord platform + BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform Int8Rep -> b8 @@ -142,8 +141,7 @@ primRepForeignHint :: PrimRep -> ForeignHint primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" -primRepForeignHint LiftedRep = AddrHint -primRepForeignHint UnliftedRep = AddrHint +primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint primRepForeignHint Int16Rep = SignedHint @@ -437,13 +435,19 @@ -- other. This includes the case that the two registers are the same -- STG register. See Note [Overlapping global registers] for details. regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool -regsOverlap platform (CmmGlobal g) (CmmGlobal g') - | Just real <- globalRegMaybe platform g, - Just real' <- globalRegMaybe platform g', - real == real' - = True +regsOverlap platform (CmmGlobal (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _)) + = globalRegsOverlap platform g1 g2 regsOverlap _ reg reg' = reg == reg' +globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool +globalRegsOverlap platform g1 g2 + | Just real <- globalRegMaybe platform g1 + , Just real' <- globalRegMaybe platform g2 + , real == real' + = True + | otherwise + = g1 == g2 + -- | Returns True if the STG register is used by the expression, in -- the sense that a store to the register might affect the value of -- the expression. @@ -461,6 +465,27 @@ reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es _ `regUsedIn_` CmmStackSlot _ _ = False +globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool +globalRegUsedIn platform = globalRegUsedIn_ where + _ `globalRegUsedIn_` CmmLit _ + = False + reg `globalRegUsedIn_` CmmLoad e _ _ + = reg `globalRegUsedIn_` e + reg `globalRegUsedIn_` CmmReg reg' + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmRegOff reg' _ + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmMachOp _ es + = any (reg `globalRegUsedIn_`) es + _ `globalRegUsedIn_` CmmStackSlot _ _ + = False + -------------------------------------------- -- -- mkLiveness @@ -571,12 +596,12 @@ -- Access to common global registers baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, - spLimExpr, hpLimExpr, cccsExpr :: CmmExpr -baseExpr = CmmReg baseReg -spExpr = CmmReg spReg -spLimExpr = CmmReg spLimReg -hpExpr = CmmReg hpReg -hpLimExpr = CmmReg hpLimReg -currentTSOExpr = CmmReg currentTSOReg -currentNurseryExpr = CmmReg currentNurseryReg -cccsExpr = CmmReg cccsReg + spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr +baseExpr p = CmmReg $ baseReg p +spExpr p = CmmReg $ spReg p +spLimExpr p = CmmReg $ spLimReg p +hpExpr p = CmmReg $ hpReg p +hpLimExpr p = CmmReg $ hpLimReg p +currentTSOExpr p = CmmReg $ currentTSOReg p +currentNurseryExpr p = CmmReg $ currentNurseryReg p +cccsExpr p = CmmReg $ cccsReg p diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -119,7 +119,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Utils.Logger @@ -1127,15 +1127,15 @@ -- On powerpc (non-PIC), it's easier to jump directly to a label than -- to use the register table, so we replace these registers -- with the corresponding labels: - CmmReg (CmmGlobal EagerBlackholeInfo) + CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _)) | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) - CmmReg (CmmGlobal GCEnter1) + CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _)) | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) - CmmReg (CmmGlobal GCFun) + CmmReg (CmmGlobal (GlobalRegUse GCFun _)) | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs --- a/compiler/GHC/CmmToAsm/AArch64.hs +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -47,7 +47,6 @@ patchRegsOfInstr = AArch64.patchRegsOfInstr isJumpishInstr = AArch64.isJumpishInstr jumpDestsOfInstr = AArch64.jumpDestsOfInstr - canFallthroughTo = AArch64.canFallthroughTo patchJumpInstr = AArch64.patchJumpInstr mkSpillInstr = AArch64.mkSpillInstr mkLoadInstr = AArch64.mkLoadInstr diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -3,6 +3,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr @@ -150,10 +151,10 @@ -- Generate location directive dbg <- getDebugBlock (entryLabel block) loc_instrs <- case dblSourceTick =<< dbg of - Just (SourceNote span name) + Just (SourceNote span (LexicalFastString name)) -> do fileId <- getFileId (srcSpanFile span) let line = srcSpanStartLine span; col = srcSpanStartCol span - return $ unitOL $ LOCATION fileId line col name + return $ unitOL $ LOCATION fileId line col (unpackFS name) _ -> return nilOL (mid_instrs,mid_bid) <- stmtsToInstrs id stmts (!tail_instrs,_) <- stmtToInstrs mid_bid tail @@ -297,7 +298,7 @@ CmmAssign reg src | isFloatType ty -> assignReg_FltCode format reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -350,10 +351,10 @@ getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) -getRegisterReg platform (CmmGlobal mid) +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) = case globalRegMaybe platform mid of Just reg -> RegReal reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this -- platform. Hence if it's not mapped to a registers something @@ -497,7 +498,7 @@ -- Generic case. getRegister' config plat expr = case expr of - CmmReg (CmmGlobal PicBaseReg) + CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg) CmmLit lit -> case lit of @@ -615,19 +616,19 @@ CmmStackSlot _ _ -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) CmmReg reg - -> return (Fixed (cmmTypeFormat (cmmRegType plat reg)) + -> return (Fixed (cmmTypeFormat (cmmRegType reg)) (getRegisterReg plat reg) nilOL) CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do getRegister' config plat $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType plat reg) + where width = typeWidth (cmmRegType reg) CmmRegOff reg off -> do (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) (reg, _format, code) <- getSomeReg $ CmmReg reg return $ Any (intFormat width) (\dst -> off_code `appOL` code `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r)) - where width = typeWidth (cmmRegType plat reg) + where width = typeWidth (cmmRegType reg) @@ -708,14 +709,14 @@ , w == W32 || w == W64 -- Work around #23749 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)] | n > 0 && n < 4096 , w == W32 || w == W64 -- Work around #23749 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do @@ -787,15 +788,15 @@ -- 3. Logic &&, || CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg - -- Generic case. + -- Generic binary case. CmmMachOp op [x, y] -> do -- alright, so we have an operation, and two expressions. And we want to essentially do -- ensure we get float regs (TODO(Ben): What?) @@ -968,7 +969,44 @@ -- TODO - op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ + (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + + -- Generic ternary case. + CmmMachOp op [x, y, z] -> + + case op of + + -- Floating-point fused multiply-add operations + + -- x86 fmadd x * y + z <=> AArch64 fmadd : d = r1 * r2 + r3 + -- x86 fmsub x * y - z <=> AArch64 fnmsub: d = r1 * r2 - r3 + -- x86 fnmadd - x * y + z <=> AArch64 fmsub : d = - r1 * r2 + r3 + -- x86 fnmsub - x * y - z <=> AArch64 fnmadd: d = - r1 * r2 - r3 + + MO_FMA var w -> case var of + FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a) + FMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a) + FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a) + FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a) + + _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ + (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + + where + float3Op w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + (reg_fz, format_z, code_fz) <- getFloatReg z + massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $ + text "float3Op: non-float" + return $ + Any (floatFormat w) $ \ dst -> + code_fx `appOL` + code_fy `appOL` + code_fz `appOL` + op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz) + CmmMachOp _op _xs -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) @@ -1795,9 +1833,9 @@ readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do -- gp/fp reg -> dst platform <- getPlatform - let rep = cmmRegType platform (CmmLocal dst) + let rep = cmmRegType (CmmLocal dst) format = cmmTypeFormat rep - w = cmmRegWidth platform (CmmLocal dst) + w = cmmRegWidth (CmmLocal dst) r_dst = getRegisterReg platform (CmmLocal dst) if isFloatFormat format then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -32,9 +32,9 @@ import GHC.Stack --- | TODO: verify this! -stackFrameHeaderSize :: Platform -> Int -stackFrameHeaderSize _ = 64 +-- | LR and FP (8 byte each) are the prologue of each stack frame +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * 8 -- | All registers are 8 byte wide. spillSlotSize :: Int @@ -49,14 +49,13 @@ maxSpillSlots :: NCGConfig -> Int maxSpillSlots config -- = 0 -- set to zero, to see when allocMoreStack has to fire. - = let platform = ncgPlatform config - in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + = ((ncgSpillPreallocSize config - stackFrameHeaderSize) `div` spillSlotSize) - 1 -- | Convert a spill slot number to a *byte* offset, with no sign. spillSlotToOffset :: NCGConfig -> Int -> Int -spillSlotToOffset config slot - = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot +spillSlotToOffset _ slot + = stackFrameHeaderSize + spillSlotSize * slot -- | Get the registers that are being used by this instruction. -- regUsage doesn't need to do any trickery for jumps and such. @@ -143,6 +142,8 @@ SCVTF dst src -> usage (regOp src, regOp dst) FCVTZS dst src -> usage (regOp src, regOp dst) FABS dst src -> usage (regOp src, regOp dst) + FMA _ dst src1 src2 src3 -> + usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) _ -> panic $ "regUsageOfInstr: " ++ instrCon instr @@ -175,8 +176,6 @@ interesting _ (RegReal (RealRegSingle (-1))) = False interesting platform (RegReal (RealRegSingle i)) = freeReg platform i --- Note [AArch64 Register assignments] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 -- @@ -199,8 +198,6 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim --- --- TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters = map regSingle [0..18] @@ -285,6 +282,9 @@ SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) + FMA s o1 o2 o3 o4 -> + FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand @@ -328,12 +328,6 @@ jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = [] -canFallthroughTo :: Instr -> BlockId -> Bool -canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid -canFallthroughTo (J (TBlock target)) bid = bid == target -canFallthroughTo (B (TBlock target)) bid = bid == target -canFallthroughTo _ _ = False - -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join -- points. @@ -375,13 +369,13 @@ -> [Instr] mkSpillInstr config reg delta slot = - case (spillSlotToOffset config slot) - delta of + case off - delta of imm | -256 <= imm && imm <= 255 -> [ mkStrSp imm ] imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff -> [ mkStrSp imm ] imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) , mkStrIp0 (imm .&. 0xfff) ] - imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm) + imm -> pprPanic "mkSpillInstr" (text "Unable to spill register into" <+> int imm) where a .&~. b = a .&. (complement b) @@ -402,13 +396,13 @@ -> [Instr] mkLoadInstr config reg delta slot = - case (spillSlotToOffset config slot) - delta of + case off - delta of imm | -256 <= imm && imm <= 255 -> [ mkLdrSp imm ] imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff -> [ mkLdrSp imm ] imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) , mkLdrIp0 (imm .&. 0xfff) ] - imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm) + imm -> pprPanic "mkLoadInstr" (text "Unable to load spilled register at" <+> int imm) where a .&~. b = a .&. (complement b) @@ -661,6 +655,14 @@ -- Float ABSolute value | FABS Operand Operand + -- | Floating-point fused multiply-add instructions + -- + -- - fmadd : d = r1 * r2 + r3 + -- - fnmsub: d = r1 * r2 - r3 + -- - fmsub : d = - r1 * r2 + r3 + -- - fnmadd: d = - r1 * r2 - r3 + | FMA FMASign Operand Operand Operand Operand + instrCon :: Instr -> String instrCon i = case i of @@ -726,6 +728,12 @@ SCVTF{} -> "SCVTF" FCVTZS{} -> "FCVTZS" FABS{} -> "FABS" + FMA variant _ _ _ _ -> + case variant of + FMAdd -> "FMADD" + FMSub -> "FMSUB" + FNMAdd -> "FNMADD" + FNMSub -> "FNMSUB" data Target = TBlock BlockId diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -18,7 +18,6 @@ import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -29,18 +28,16 @@ import GHC.Utils.Panic -pprProcAlignment :: IsDoc doc => NCGConfig -> doc -pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) - where - platform = ncgPlatform config - pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = - pprSectionAlign config section $$ pprDatas config dats + let platform = ncgPlatform config + in + pprSectionAlign config section $$ pprDatas platform dats pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - let platform = ncgPlatform config in - pprProcAlignment config $$ + let platform = ncgPlatform config + with_dwarf = ncgDwarfEnabled config + in case topInfoTable proc of Nothing -> -- special case for code without info table: @@ -48,7 +45,7 @@ -- do not -- pprProcAlignment config $$ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock config top_info) blocks) $$ + vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$ (if ncgDwarfEnabled config then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$ pprSizeDecl platform lbl @@ -59,7 +56,7 @@ (if platformHasSubsectionsViaSymbols platform then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') else empty) $$ - vcat (map (pprBasicBlock config top_info) blocks) $$ + vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -80,10 +77,6 @@ $$ pprTypeDecl platform lbl $$ line (pprAsmLabel platform lbl <> char ':') -pprAlign :: IsDoc doc => Platform -> Alignment -> doc -pprAlign _platform alignment - = line $ text "\t.balign " <> int (alignmentBytes alignment) - -- | Print appropriate alignment for the given section type. pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc pprAlignForSection _platform _seg @@ -111,13 +104,13 @@ then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr +pprBasicBlock :: IsDoc doc => Platform -> {- dwarf enabled -} Bool -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc -pprBasicBlock config info_env (BasicBlock blockid instrs) +pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ - (if ncgDwarfEnabled config + (if with_dwarf then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':') else empty ) @@ -128,16 +121,15 @@ f _ = True asmLbl = blockLbl blockid - platform = ncgPlatform config maybe_infotable c = case mapLookup blockid info_env of Nothing -> c Just (CmmStaticsRaw info_lbl info) -> -- pprAlignForSection platform Text $$ infoTableLoc $$ - vcat (map (pprData config) info) $$ + vcat (map (pprData platform) info) $$ pprLabel platform info_lbl $$ c $$ - (if ncgDwarfEnabled config + (if with_dwarf then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':') else empty) -- Make sure the info table has the right .loc for the block @@ -146,34 +138,31 @@ (l@LOCATION{} : _) -> pprInstr platform l _other -> empty -pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc +pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' - = pprGloblDecl (ncgPlatform config) alias - $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') + = pprGloblDecl platform alias + $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') -pprDatas config (CmmStaticsRaw lbl dats) - = vcat (pprLabel platform lbl : map (pprData config) dats) - where - platform = ncgPlatform config +pprDatas platform (CmmStaticsRaw lbl dats) + = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc -pprData _config (CmmString str) = line (pprString str) -pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) +pprData :: IsDoc doc => Platform -> CmmStatic -> doc +pprData _platform (CmmString str) = line (pprString str) +pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path) -pprData config (CmmUninitialised bytes) - = line $ let platform = ncgPlatform config - in if platformOS platform == OSDarwin +pprData platform (CmmUninitialised bytes) + = line $ if platformOS platform == OSDarwin then text ".space " <> int bytes else text ".skip " <> int bytes -pprData config (CmmStaticLit lit) = pprDataItem config lit +pprData platform (CmmStaticLit lit) = pprDataItem platform lit pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl @@ -207,12 +196,10 @@ then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc -pprDataItem config lit +pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc +pprDataItem platform lit = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where - platform = ncgPlatform config - imm = litToImm lit ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] @@ -330,7 +317,6 @@ | w == W64 = text "sp" | w == W32 = text "wsp" - -- See Note [AArch64 Register assignments] ppr_reg_no w i | i < 0, w == W32 = text "wzr" | i < 0, w == W64 = text "xzr" @@ -550,6 +536,13 @@ SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2 FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2 FABS o1 o2 -> op2 (text "\tfabs") o1 o2 + FMA variant d r1 r2 r3 -> + let fma = case variant of + FMAdd -> text "\tfmadd" + FMSub -> text "\tfmsub" + FNMAdd -> text "\tfnmadd" + FNMSub -> text "\tfnmsub" + in op4 fma d r1 r2 r3 where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs --- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -17,7 +17,6 @@ import GHC.Utils.Panic import GHC.Platform --- TODO: Should this include the zero register? allMachRegNos :: [RegNo] allMachRegNos = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed. 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 @@ -14,6 +14,7 @@ where import GHC.Prelude hiding (head, init, last, tail) +import qualified GHC.Prelude as Partial (head, tail) import GHC.Platform @@ -41,7 +42,6 @@ import GHC.Utils.Misc import Data.List (sortOn, sortBy, nub) -import qualified Data.List as Partial (head, tail) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import Data.Foldable (toList) @@ -777,9 +777,10 @@ dropJumps _ [] = [] dropJumps info (BasicBlock lbl ins:todo) | Just ins <- nonEmpty ins --This can happen because of shortcutting + , [dest] <- jumpDestsOfInstr (NE.last ins) , BasicBlock nextLbl _ : _ <- todo - , canFallthroughTo (NE.last ins) nextLbl - , not (mapMember nextLbl info) + , not (mapMember dest info) + , nextLbl == dest = BasicBlock lbl (NE.init ins) : dropJumps info todo | otherwise = BasicBlock lbl ins : dropJumps info todo 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 @@ -60,16 +60,12 @@ import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom import GHC.CmmToAsm.CFG.Weight -import GHC.Data.Word64Map.Strict (Word64Map) -import GHC.Data.Word64Set (Word64Set) import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) import qualified Data.IntMap.Strict as IM -import qualified GHC.Data.Word64Map.Strict as WM import qualified Data.Map as M import qualified Data.IntSet as IS -import qualified GHC.Data.Word64Set as WS import qualified Data.Set as S import Data.Tree import Data.Bifunctor @@ -94,7 +90,6 @@ import Control.Monad import GHC.Data.UnionFind -import Data.Word type Prob = Double @@ -856,7 +851,7 @@ --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ... rooted = ( fromBlockId root - , toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set) + , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet) tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId -- Map from Nodes to their dominators @@ -903,10 +898,10 @@ loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] - toWord64Set :: LabelSet -> Word64Set - toWord64Set s = WS.fromList . map fromBlockId . setElems $ s - toWord64Map :: LabelMap a -> Word64Map a - toWord64Map m = WM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m + toIntSet :: LabelSet -> IntSet + toIntSet s = IS.fromList . map fromBlockId . setElems $ s + toIntMap :: LabelMap a -> IntMap a + toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m mkDomMap :: Tree BlockId -> LabelMap LabelSet mkDomMap root = mapFromList $ go setEmpty root @@ -921,10 +916,10 @@ (\n -> go (setInsert (rootLabel n) parents) n) leaves - fromBlockId :: BlockId -> Word64 + fromBlockId :: BlockId -> Int fromBlockId = getKey . getUnique - toBlockId :: Word64 -> BlockId + toBlockId :: Int -> BlockId toBlockId = mkBlockId . mkUniqueGrimily -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs --- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs +++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs @@ -21,8 +21,8 @@ /Advanced Compiler Design and Implementation/, 1997. \[3\] Brisk, Sarrafzadeh, - /Interference CGraphs for Procedures in Static Single/ - /Information Form are Interval CGraphs/, 2007. + /Interference Graphs for Procedures in Static Single/ + /Information Form are Interval Graphs/, 2007. * Strictness @@ -40,7 +40,7 @@ ,pddfs,rpddfs ,fromAdj,fromEdges ,toAdj,toEdges - ,asTree,asCGraph + ,asTree,asGraph ,parents,ancestors ) where @@ -61,23 +61,14 @@ import Data.Array.Base (unsafeNewArray_ ,unsafeWrite,unsafeRead) -import GHC.Data.Word64Set (Word64Set) -import qualified GHC.Data.Word64Set as WS -import GHC.Data.Word64Map (Word64Map) -import qualified GHC.Data.Word64Map as WM -import Data.Word ----------------------------------------------------------------------------- --- Compacted nodes; these can be stored in contiguous arrays -type CNode = Int -type CGraph = IntMap IntSet - -type Node = Word64 -type Path = [Node] -type Edge = (Node, Node) -type Graph = Word64Map Word64Set -type Rooted = (Node, Graph) +type Node = Int +type Path = [Node] +type Edge = (Node,Node) +type Graph = IntMap IntSet +type Rooted = (Node, Graph) ----------------------------------------------------------------------------- @@ -120,7 +111,7 @@ -- | /Immediate post-dominators/. -- Complexity as for @idom@. ipdom :: Rooted -> [(Node,Node)] -ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg))) +ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) ----------------------------------------------------------------------------- @@ -135,24 +126,24 @@ ----------------------------------------------------------------------------- type Dom s a = S s (Env s) a -type NodeSet = Word64Set -type NodeMap a = Word64Map a +type NodeSet = IntSet +type NodeMap a = IntMap a data Env s = Env - {succE :: !CGraph - ,predE :: !CGraph - ,bucketE :: !CGraph + {succE :: !Graph + ,predE :: !Graph + ,bucketE :: !Graph ,dfsE :: {-# UNPACK #-}!Int - ,zeroE :: {-# UNPACK #-}!CNode - ,rootE :: {-# UNPACK #-}!CNode - ,labelE :: {-# UNPACK #-}!(Arr s CNode) - ,parentE :: {-# UNPACK #-}!(Arr s CNode) - ,ancestorE :: {-# UNPACK #-}!(Arr s CNode) - ,childE :: {-# UNPACK #-}!(Arr s CNode) - ,ndfsE :: {-# UNPACK #-}!(Arr s CNode) + ,zeroE :: {-# UNPACK #-}!Node + ,rootE :: {-# UNPACK #-}!Node + ,labelE :: {-# UNPACK #-}!(Arr s Node) + ,parentE :: {-# UNPACK #-}!(Arr s Node) + ,ancestorE :: {-# UNPACK #-}!(Arr s Node) + ,childE :: {-# UNPACK #-}!(Arr s Node) + ,ndfsE :: {-# UNPACK #-}!(Arr s Node) ,dfnE :: {-# UNPACK #-}!(Arr s Int) ,sdnoE :: {-# UNPACK #-}!(Arr s Int) ,sizeE :: {-# UNPACK #-}!(Arr s Int) - ,domE :: {-# UNPACK #-}!(Arr s CNode) + ,domE :: {-# UNPACK #-}!(Arr s Node) ,rnE :: {-# UNPACK #-}!(Arr s Node)} ----------------------------------------------------------------------------- @@ -197,7 +188,7 @@ ----------------------------------------------------------------------------- -eval :: CNode -> Dom s CNode +eval :: Node -> Dom s Node eval v = do n0 <- zeroM a <- ancestorM v @@ -214,7 +205,7 @@ True-> return l False-> return la -compress :: CNode -> Dom s () +compress :: Node -> Dom s () compress v = do n0 <- zeroM a <- ancestorM v @@ -233,7 +224,7 @@ ----------------------------------------------------------------------------- -link :: CNode -> CNode -> Dom s () +link :: Node -> Node -> Dom s () link v w = do n0 <- zeroM lw <- labelM w @@ -277,7 +268,7 @@ ----------------------------------------------------------------------------- -dfsDom :: CNode -> Dom s () +dfsDom :: Node -> Dom s () dfsDom i = do _ <- go i n0 <- zeroM @@ -302,10 +293,10 @@ initEnv :: Rooted -> ST s (Env s) initEnv (r0,g0) = do - -- CGraph renumbered to indices from 1 to |V| + -- Graph renumbered to indices from 1 to |V| let (g,rnmap) = renum 1 g0 pred = predG g -- reverse graph - root = rnmap WM.! r0 -- renamed root + root = rnmap IM.! r0 -- renamed root n = IM.size g ns = [0..n] m = n+1 @@ -313,9 +304,9 @@ let bucket = IM.fromList (zip ns (repeat mempty)) - rna <- newW m + rna <- newI m writes rna (fmap swap - (WM.toList rnmap)) + (IM.toList rnmap)) doms <- newI m sdno <- newI m @@ -370,33 +361,33 @@ ----------------------------------------------------------------------------- -zeroM :: Dom s CNode +zeroM :: Dom s Node zeroM = gets zeroE -domM :: CNode -> Dom s CNode +domM :: Node -> Dom s Node domM = fetch domE -rootM :: Dom s CNode +rootM :: Dom s Node rootM = gets rootE -succsM :: CNode -> Dom s [CNode] +succsM :: Node -> Dom s [Node] succsM i = gets (IS.toList . (! i) . succE) -predsM :: CNode -> Dom s [CNode] +predsM :: Node -> Dom s [Node] predsM i = gets (IS.toList . (! i) . predE) -bucketM :: CNode -> Dom s [CNode] +bucketM :: Node -> Dom s [Node] bucketM i = gets (IS.toList . (! i) . bucketE) -sizeM :: CNode -> Dom s Int +sizeM :: Node -> Dom s Int sizeM = fetch sizeE -sdnoM :: CNode -> Dom s Int +sdnoM :: Node -> Dom s Int sdnoM = fetch sdnoE --- dfnM :: CNode -> Dom s Int +-- dfnM :: Node -> Dom s Int -- dfnM = fetch dfnE -ndfsM :: Int -> Dom s CNode +ndfsM :: Int -> Dom s Node ndfsM = fetch ndfsE -childM :: CNode -> Dom s CNode +childM :: Node -> Dom s Node childM = fetch childE -ancestorM :: CNode -> Dom s CNode +ancestorM :: Node -> Dom s Node ancestorM = fetch ancestorE -parentM :: CNode -> Dom s CNode +parentM :: Node -> Dom s Node parentM = fetch parentE -labelM :: CNode -> Dom s CNode +labelM :: Node -> Dom s Node labelM = fetch labelE nextM :: Dom s Int nextM = do @@ -431,9 +422,6 @@ newI :: Int -> ST s (Arr s Int) newI = new -newW :: Int -> ST s (Arr s Node) -newW = new - writes :: (MArray (A s) a (ST s)) => Arr s a -> [(Int,a)] -> ST s () writes a xs = forM_ xs (\(i,x) -> (a.=x) i) @@ -443,18 +431,18 @@ (!) g n = maybe mempty id (IM.lookup n g) fromAdj :: [(Node, [Node])] -> Graph -fromAdj = WM.fromList . fmap (second WS.fromList) +fromAdj = IM.fromList . fmap (second IS.fromList) fromEdges :: [Edge] -> Graph -fromEdges = collectW WS.union fst (WS.singleton . snd) +fromEdges = collectI IS.union fst (IS.singleton . snd) toAdj :: Graph -> [(Node, [Node])] -toAdj = fmap (second WS.toList) . WM.toList +toAdj = fmap (second IS.toList) . IM.toList toEdges :: Graph -> [Edge] toEdges = concatMap (uncurry (fmap . (,))) . toAdj -predG :: CGraph -> CGraph +predG :: Graph -> Graph predG g = IM.unionWith IS.union (go g) g0 where g0 = fmap (const mempty) g go = flip IM.foldrWithKey mempty (\i a m -> @@ -463,24 +451,15 @@ m (IS.toList a)) -predGW :: Graph -> Graph -predGW g = WM.unionWith WS.union (go g) g0 - where g0 = fmap (const mempty) g - go = flip WM.foldrWithKey mempty (\i a m -> - foldl' (\m p -> WM.insertWith mappend p - (WS.singleton i) m) - m - (WS.toList a)) - pruneReach :: Rooted -> Rooted pruneReach (r,g) = (r,g2) where is = reachable (maybe mempty id - . flip WM.lookup g) $ r - g2 = WM.fromList - . fmap (second (WS.filter (`WS.member`is))) - . filter ((`WS.member`is) . fst) - . WM.toList $ g + . flip IM.lookup g) $ r + g2 = IM.fromList + . fmap (second (IS.filter (`IS.member`is))) + . filter ((`IS.member`is) . fst) + . IM.toList $ g tip :: Tree a -> (a, [Tree a]) tip (Node a ts) = (a, ts) @@ -497,28 +476,26 @@ in p acc' xs ++ concatMap (go acc') xs p is = fmap (flip (,) is . rootLabel) -asCGraph :: Tree Node -> Rooted -asCGraph t@(Node a _) = let g = go t in (a, fromAdj g) +asGraph :: Tree Node -> Rooted +asGraph t@(Node a _) = let g = go t in (a, fromAdj g) where go (Node a ts) = let as = (fst . unzip . fmap tip) ts in (a, as) : concatMap go ts asTree :: Rooted -> Tree Node -asTree (r,g) = let go a = Node a (fmap go ((WS.toList . f) a)) +asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a)) f = (g !) in go r - where (!) g n = maybe mempty id (WM.lookup n g) - reachable :: (Node -> NodeSet) -> (Node -> NodeSet) -reachable f a = go (WS.singleton a) a +reachable f a = go (IS.singleton a) a where go seen a = let s = f a - as = WS.toList (s `WS.difference` seen) - in foldl' go (s `WS.union` seen) as + as = IS.toList (s `IS.difference` seen) + in foldl' go (s `IS.union` seen) as -collectW :: (c -> c -> c) - -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c -collectW (<>) f g - = foldl' (\m a -> WM.insertWith (<>) +collectI :: (c -> c -> c) + -> (a -> Int) -> (a -> c) -> [a] -> IntMap c +collectI (<>) f g + = foldl' (\m a -> IM.insertWith (<>) (f a) (g a) m) mempty @@ -527,12 +504,12 @@ -- Gives nodes sequential names starting at n. -- Returns the new graph and a mapping. -- (renamed, old -> new) -renum :: Int -> Graph -> (CGraph, NodeMap CNode) +renum :: Int -> Graph -> (Graph, NodeMap Node) renum from = (\(_,m,g)->(g,m)) - . WM.foldrWithKey + . IM.foldrWithKey (\i ss (!n,!env,!new)-> let (j,n2,env2) = go n env i - (n3,env3,ss2) = WS.fold + (n3,env3,ss2) = IS.fold (\k (!n,!env,!new)-> case go n env k of (l,n2,env2)-> (n2,env2,l `IS.insert` new)) @@ -540,13 +517,13 @@ new2 = IM.insertWith IS.union j ss2 new in (n3,env3,new2)) (from,mempty,mempty) where go :: Int - -> NodeMap CNode + -> NodeMap Node -> Node - -> (CNode,Int,NodeMap CNode) + -> (Node,Int,NodeMap Node) go !n !env i = - case WM.lookup i env of + case IM.lookup i env of Just j -> (j,n,env) - Nothing -> (n,n+1,WM.insert i n env) + Nothing -> (n,n+1,IM.insert i n env) ----------------------------------------------------------------------------- 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,7 +5,8 @@ import GHC.Prelude import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Cmm.Expr +import GHC.Data.FastString import GHC.Settings.Config ( cProjectName, cProjectVersion ) import GHC.Types.Tickish ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock @@ -82,7 +83,7 @@ (framesU, us'') = takeUniqFromSupply us' frameSct = dwarfFrameSection platform $$ line (dwarfFrameLabel <> colon) $$ - pprDwarfFrame platform (debugFrame framesU procs) + pprDwarfFrame platform (debugFrame platform framesU procs) -- .aranges section: Information about the bounds of compilation units aranges' | ncgSplitSections config = map mkDwarfARange procs @@ -177,7 +178,8 @@ procToDwarf config prc = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc) , dwName = case dblSourceTick prc of - Just s@SourceNote{} -> sourceName s + Just s@SourceNote{} -> case sourceName s of + LexicalFastString s -> unpackFS s _otherwise -> show (dblLabel prc) , dwLabel = dblCLabel prc , dwParent = fmap mkAsmTempDieLabel @@ -215,15 +217,15 @@ -- | Generates the data for the debug frame section, which encodes the -- desired stack unwind behaviour for the debugger -debugFrame :: Unique -> [DebugBlock] -> DwarfFrame -debugFrame u procs +debugFrame :: Platform -> Unique -> [DebugBlock] -> DwarfFrame +debugFrame p u procs = DwarfFrame { dwCieLabel = mkAsmTempLabel u , dwCieInit = initUws , dwCieProcs = map (procToFrame initUws) procs } where initUws :: UnwindTable - initUws = Map.fromList [(Sp, Just (UwReg Sp 0))] + initUws = Map.fromList [(Sp, Just (UwReg (GlobalRegUse Sp $ bWord p) 0))] -- | Generates unwind information for a procedure debug block procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -31,7 +31,7 @@ import GHC.Cmm.DebugBlock import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Cmm.Expr import GHC.Utils.Encoding import GHC.Data.FastString import GHC.Utils.Outputable @@ -469,7 +469,7 @@ = if o' >= 0 then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' -pprSetUnwind plat Sp (_, Just (UwReg s' o')) +pprSetUnwind plat Sp (_, Just (UwReg (GlobalRegUse s' _) o')) = if o' >= 0 then pprByte dW_CFA_def_cfa $$ pprLEBRegNo plat s' $$ @@ -479,7 +479,7 @@ pprLEBInt o' pprSetUnwind plat Sp (_, Just uw) = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw -pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) +pprSetUnwind plat g (_, Just (UwDeref (UwReg (GlobalRegUse Sp _) o))) | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) @@ -491,7 +491,7 @@ = pprByte dW_CFA_expression $$ pprLEBRegNo plat g $$ pprUnwindExpr plat True uw -pprSetUnwind plat g (_, Just (UwReg g' 0)) +pprSetUnwind plat g (_, Just (UwReg (GlobalRegUse g' _) 0)) | g == g' = pprByte dW_CFA_same_value $$ pprLEBRegNo plat g @@ -513,12 +513,14 @@ = let pprE (UwConst i) | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... - pprE (UwReg Sp i) | spIsCFA - = if i == 0 - then pprByte dW_OP_call_frame_cfa - else pprE (UwPlus (UwReg Sp 0) (UwConst i)) - pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ - pprLEBInt i + pprE (UwReg r@(GlobalRegUse Sp _) i) + | spIsCFA + = if i == 0 + then pprByte dW_OP_call_frame_cfa + else pprE (UwPlus (UwReg r 0) (UwConst i)) + pprE (UwReg (GlobalRegUse g _) i) + = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ + pprLEBInt i pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus 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 @@ -71,16 +71,10 @@ :: instr -> Bool - -- | Give the possible *local block* destinations of this jump instruction. + -- | Give the possible destinations of this jump instruction. -- Must be defined for all jumpish instructions. jumpDestsOfInstr :: instr -> [BlockId] - - -- | Check if the instr always transfers control flow - -- to the given block. Used by code layout to eliminate - -- jumps that can be replaced by fall through. - canFallthroughTo - :: instr -> BlockId -> Bool -- | Change the destination of this jump instruction. 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 @@ -79,15 +79,8 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, - -- | Does this jump always jump to a single destination and is shortcutable? - -- - -- We use this to determine shortcutable instructions - See Note [What is shortcutting] - -- Note that if we return a destination here we *most* support the relevant shortcutting in - -- shortcutStatics for jump tables and shortcutJump for the instructions itself. canShortcut :: instr -> Maybe jumpDest, - -- | Replace references to blockIds with other destinations - used to update jump tables. shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, - -- | Change the jump destination(s) of an instruction. shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, -- | 'Module' is only for printing internal labels. See Note [Internal proc -- labels] in CLabel. @@ -112,25 +105,6 @@ -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \@ -- when possible. } - -{- Note [supporting shortcutting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the concept of shortcutting see Note [What is shortcutting]. - -In order to support shortcutting across multiple backends uniformly we -use canShortcut, shortcutStatics and shortcutJump. - -canShortcut tells us if the backend support shortcutting of a instruction -and if so what destination we should retarget instruction to instead. - -shortcutStatics exists to allow us to update jump destinations in jump tables. - -shortcutJump updates the instructions itself. - -A backend can opt out of those by always returning Nothing for canShortcut -and implementing shortcutStatics/shortcutJump as \_ x -> x - --} {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -166,7 +166,7 @@ | OSAIX <- platformOS platform = CmmMachOp (MO_Add W32) - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) @@ -175,7 +175,7 @@ -- both ABI versions default to medium code model | ArchPPC_64 _ <- platformArch platform = CmmMachOp (MO_Add W32) -- code model medium - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) @@ -184,7 +184,7 @@ | (ncgPIC config || ncgExternalDynamicRefs config) && absoluteLabel lbl = CmmMachOp (MO_Add (wordWidth platform)) - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs --- a/compiler/GHC/CmmToAsm/PPC.hs +++ b/compiler/GHC/CmmToAsm/PPC.hs @@ -46,7 +46,6 @@ patchRegsOfInstr = PPC.patchRegsOfInstr isJumpishInstr = PPC.isJumpishInstr jumpDestsOfInstr = PPC.jumpDestsOfInstr - canFallthroughTo = PPC.canFallthroughTo patchJumpInstr = PPC.patchJumpInstr mkSpillInstr = PPC.mkSpillInstr mkLoadInstr = PPC.mkLoadInstr 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 @@ -129,10 +129,10 @@ -- Generate location directive dbg <- getDebugBlock (entryLabel block) loc_instrs <- case dblSourceTick =<< dbg of - Just (SourceNote span name) + Just (SourceNote span (LexicalFastString name)) -> do fileid <- getFileId (srcSpanFile span) let line = srcSpanStartLine span; col =srcSpanStartCol span - return $ unitOL $ LOCATION fileid line col name + return $ unitOL $ LOCATION fileid line col (unpackFS name) _ -> return nilOL mid_instrs <- stmtsToInstrs stmts tail_instrs <- stmtToInstrs tail @@ -171,7 +171,7 @@ | target32Bit platform && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -233,7 +233,7 @@ = getLocalRegReg local_reg getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of + = case globalRegMaybe platform (globalRegUseGlobalReg mid) of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the @@ -253,12 +253,12 @@ -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmExpr -> CmmExpr -mangleIndexTree platform (CmmRegOff reg off) +mangleIndexTree :: CmmExpr -> CmmExpr +mangleIndexTree (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) + where width = typeWidth (cmmRegType reg) -mangleIndexTree _ _ +mangleIndexTree _ = panic "PPC.CodeGen.mangleIndexTree: no match" -- ----------------------------------------------------------------------------- @@ -404,7 +404,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) +getRegister' _ platform (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) | OSAIX <- platformOS platform = do let code dst = toOL [ LD II32 dst tocAddr ] tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]")) @@ -416,11 +416,11 @@ | otherwise = return (Fixed II64 toc nilOL) getRegister' _ platform (CmmReg reg) - = return (Fixed (cmmTypeFormat (cmmRegType platform reg)) + = return (Fixed (cmmTypeFormat (cmmRegType reg)) (getRegisterReg platform reg) nilOL) getRegister' config platform tree@(CmmRegOff _ _) - = getRegister' config platform (mangleIndexTree platform tree) + = getRegister' config platform (mangleIndexTree tree) -- for 32-bit architectures, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) @@ -649,7 +649,22 @@ code <- remainderCode rep sgn tmp x y return (Any fmt code) +getRegister' _ _ (CmmMachOp mop [x, y, z]) -- ternary PrimOps + = case mop of + -- x86 fmadd x * y + z <> PPC fmadd rt = ra * rc + rb + -- x86 fmsub x * y - z <> PPC fmsub rt = ra * rc - rb + -- x86 fnmadd - x * y + z ~~ PPC fnmsub rt = -(ra * rc - rb) + -- x86 fnmsub - x * y - z ~~ PPC fnmadd rt = -(ra * rc + rb) + + MO_FMA variant w -> + case variant of + FMAdd -> fma_code w (FMADD FMAdd) x y z + FMSub -> fma_code w (FMADD FMSub) x y z + FNMAdd -> fma_code w (FMADD FNMAdd) x y z + FNMSub -> fma_code w (FMADD FNMSub) x y z + _ -> panic "PPC.CodeGen.getRegister: no match" + getRegister' _ _ (CmmLit (CmmInt i rep)) | Just imm <- makeImmediate rep True i = let @@ -735,8 +750,7 @@ getAmode :: InstrForm -> CmmExpr -> NatM Amode getAmode inf tree@(CmmRegOff _ _) - = do platform <- getPlatform - getAmode inf (mangleIndexTree platform tree) + = getAmode inf (mangleIndexTree tree) getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate W32 True (-i) @@ -1752,7 +1766,7 @@ _ -> panic "genCall': unknown calling conv." argReps = map (cmmExprType platform) args - (_, argHints) = foreignTargetHints target + (argHints, _) = foreignTargetHints target roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) @@ -1952,7 +1966,7 @@ -> toOL [MR (getHiVRegFromLo r_dest) r3, MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType platform (CmmLocal dest) + where rep = cmmRegType (CmmLocal dest) r_dest = getLocalRegReg dest _ -> panic "genCCall' moveResult: Bad dest_regs" @@ -2359,10 +2373,28 @@ let code' dst = code `snocOL` instr dst src return (Any rep code') +-- | Generate code for a 4-register FMA instruction, +-- e.g. @fmadd rt ra rc rb := rt <- ra * rc + rb@. +fma_code :: Width + -> (Format -> Reg -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register +fma_code w instr ra rc rb = do + let rep = floatFormat w + (src1, code1) <- getSomeReg ra + (src2, code2) <- getSomeReg rc + (src3, code3) <- getSomeReg rb + let instrCode rt = + code1 `appOL` + code2 `appOL` + code3 `snocOL` instr rep rt src1 src2 src3 + return $ Any rep instrCode + -- There is no "remainder" instruction on the PPC, so we have to do -- it the hard way. -- The "sgn" parameter is the signedness for the division instruction - remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> InstrBlock) remainderCode rep sgn reg_q arg_x arg_y = do 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 @@ -22,7 +22,6 @@ , patchJumpInstr , patchRegsOfInstr , jumpDestsOfInstr - , canFallthroughTo , takeRegRegMoveInstr , takeDeltaInstr , mkRegRegMoveInstr @@ -281,6 +280,14 @@ | FABS Reg Reg -- abs is the same for single and double | FNEG Reg Reg -- negate is the same for single and double prec. + -- | Fused multiply-add instructions. + -- + -- - FMADD: @rd = (ra * rb) + rd@ + -- - FMSUB: @rd = ra * rb - rd@ + -- - FNMADD: @rd = -(ra * rb + rd)@ + -- - FNMSUB: @rd = -(ra * rb - rd)@ + | FMADD FMASign Format Reg Reg Reg Reg + | FCMP Reg Reg | FCTIWZ Reg Reg -- convert to integer word @@ -381,6 +388,7 @@ MFCR reg -> usage ([], [reg]) MFLR reg -> usage ([], [reg]) FETCHPC reg -> usage ([], [reg]) + FMADD _ _ rt ra rc rb -> usage ([ra, rc, rb], [rt]) _ -> noUsage where usage (src, dst) = RU (filter (interesting platform) src) @@ -468,6 +476,8 @@ FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3) FABS r1 r2 -> FABS (env r1) (env r2) FNEG r1 r2 -> FNEG (env r1) (env r2) + FMADD sgn fmt r1 r2 r3 r4 + -> FMADD sgn fmt (env r1) (env r2) (env r3) (env r4) FCMP r1 r2 -> FCMP (env r1) (env r2) FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) @@ -499,13 +509,6 @@ BL{} -> True JMP{} -> True _ -> False - -canFallthroughTo :: Instr -> BlockId -> Bool -canFallthroughTo instr bid - = case instr of - BCC _ target _ -> target == bid - BCCFAR _ target _ -> target == bid - _ -> False -- | Checks whether this instruction is a jump/branch instruction. 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 @@ -934,6 +934,9 @@ FNEG reg1 reg2 -> pprUnary (text "fneg") reg1 reg2 + FMADD signs fmt dst ra rc rb + -> pprTernaryF (pprFMASign signs) fmt dst ra rc rb + FCMP reg1 reg2 -> line $ hcat [ char '\t', @@ -1081,6 +1084,21 @@ pprReg reg2, text ", ", pprReg reg3 + ] + +pprTernaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> Reg -> doc +pprTernaryF op fmt rt ra rc rb = line $ hcat [ + char '\t', + op, + pprFFormat fmt, + char '\t', + pprReg rt, + text ", ", + pprReg ra, + text ", ", + pprReg rc, + text ", ", + pprReg rb ] pprRI :: IsLine doc => Platform -> RI -> doc diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -246,10 +246,9 @@ panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of Text - | OSMinGW32 <- platformOS platform, splitSections + | OSMinGW32 <- platformOS platform -> text ",\"xr\"" - | splitSections - -> text ",\"ax\"," <> sectionType platform "progbits" + | otherwise -> text ",\"ax\"," <> sectionType platform "progbits" CString | OSMinGW32 <- platformOS platform -> empty 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 @@ -179,8 +179,7 @@ ArchPPC -> 26 ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use. - -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this. + ArchAArch64 -> 32 ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -199,8 +199,7 @@ (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs - let fixUpInstrs = concat fixUpInstrs_ + fixUpInstrs <- concatMapM (handleComponent delta instr) sccs -- make a new basic block containing the fixup code. -- A the end of the current block we will jump to the fixup one, diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -133,11 +133,6 @@ Instr instr -> isJumpishInstr instr _ -> False - canFallthroughTo i bid - = case i of - Instr instr -> canFallthroughTo instr bid - _ -> False - jumpDestsOfInstr i = case i of Instr instr -> jumpDestsOfInstr instr diff --git a/compiler/GHC/CmmToAsm/Wasm/Asm.hs b/compiler/GHC/CmmToAsm/Wasm/Asm.hs --- a/compiler/GHC/CmmToAsm/Wasm/Asm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Asm.hs @@ -14,7 +14,7 @@ import Data.ByteString.Builder import Data.Coerce import Data.Foldable -import qualified GHC.Data.Word64Set as WS +import qualified Data.IntSet as IS import Data.Maybe import Data.Semigroup import GHC.Cmm @@ -181,9 +181,9 @@ asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@" asmTellDataSection :: - WasmTypeTag w -> WS.Word64Set -> SymName -> DataSection -> WasmAsmM () + WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM () asmTellDataSection ty_word def_syms sym DataSection {..} = do - when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym + when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym asmTellSectionHeader sec_name asmTellAlign dataSectionAlignment asmTellTabLine asm_size @@ -420,12 +420,12 @@ asmTellFunc :: WasmTypeTag w -> - WS.Word64Set -> + IS.IntSet -> SymName -> (([SomeWasmType], [SomeWasmType]), FuncBody w) -> WasmAsmM () asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do - when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym + when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym asmTellSectionHeader $ ".text." <> asm_sym asmTellLine $ asm_sym <> ":" asmTellFuncType sym func_ty diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -26,7 +26,7 @@ import qualified Data.ByteString as BS import Data.Foldable import Data.Functor -import qualified GHC.Data.Word64Set as WS +import qualified Data.IntSet as IS import Data.Semigroup import Data.String import Data.Traversable @@ -48,6 +48,7 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Map +import GHC.Types.Unique.Supply import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic import GHC.Wasm.ControlFlow.FromCmm @@ -177,7 +178,7 @@ -} globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo globalInfoFromCmmGlobalReg t reg = case reg of - VanillaReg i _ + VanillaReg i | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word) FloatReg i | i >= 1 && i <= 6 -> @@ -197,7 +198,7 @@ supportedCmmGlobalRegs :: [GlobalReg] supportedCmmGlobalRegs = - [VanillaReg i VGcPtr | i <- [1 .. 10]] + [VanillaReg i | i <- [1 .. 10]] <> [FloatReg i | i <- [1 .. 6]] <> [DoubleReg i | i <- [1 .. 6]] <> [LongReg i | i <- [1 .. 1]] @@ -815,7 +816,9 @@ lower_CmmMachOp lbl (MO_UU_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs lower_CmmMachOp lbl (MO_XX_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs lower_CmmMachOp lbl (MO_FF_Conv w0 w1) xs = lower_MO_FF_Conv lbl w0 w1 xs -lower_CmmMachOp _ _ _ = panic "lower_CmmMachOp: unreachable" +lower_CmmMachOp _ mop _ = + pprPanic "lower_CmmMachOp: unreachable" $ + vcat [ text "offending MachOp:" <+> pprMachOp mop ] -- | Lower a 'CmmLit'. Note that we don't emit 'f32.const' or -- 'f64.const' for the time being, and instead emit their relative bit @@ -872,38 +875,35 @@ lower_CmmReg _ (CmmLocal reg) = do (reg_i, SomeWasmType ty) <- onCmmLocalReg reg pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i -lower_CmmReg _ (CmmGlobal EagerBlackholeInfo) = do - ty_word <- wasmWordTypeM - pure $ - SomeWasmExpr ty_word $ - WasmExpr $ - WasmSymConst "__stg_EAGER_BLACKHOLE_info" -lower_CmmReg _ (CmmGlobal GCEnter1) = do - ty_word <- wasmWordTypeM - ty_word_cmm <- wasmWordCmmTypeM - onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] - pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" -lower_CmmReg _ (CmmGlobal GCFun) = do +lower_CmmReg lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do ty_word <- wasmWordTypeM ty_word_cmm <- wasmWordCmmTypeM - onFuncSym "__stg_gc_fun" [] [ty_word_cmm] - pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" -lower_CmmReg lbl (CmmGlobal BaseReg) = do - platform <- wasmPlatformM - lower_CmmExpr lbl $ regTableOffset platform 0 -lower_CmmReg lbl (CmmGlobal reg) = do - ty_word <- wasmWordTypeM - if + case greg of + EagerBlackholeInfo -> + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + WasmSymConst "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> do + onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" + GCFun -> do + onFuncSym "__stg_gc_fun" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" + BaseReg -> do + platform <- wasmPlatformM + lower_CmmExpr lbl $ regTableOffset platform 0 + _other | Just (sym_global, SomeWasmType ty) <- - globalInfoFromCmmGlobalReg ty_word reg -> + globalInfoFromCmmGlobalReg ty_word greg -> pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global | otherwise -> do platform <- wasmPlatformM - case someWasmTypeFromCmmType $ globalRegType platform reg of + case someWasmTypeFromCmmType reg_use_ty of SomeWasmType ty -> do (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl $ - get_GlobalReg_addr platform reg + get_GlobalReg_addr platform greg pure $ SomeWasmExpr ty $ WasmExpr $ @@ -1331,7 +1331,7 @@ [CmmActual] -> WasmCodeGenM w (WasmStatements w) lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do - ret_uniq <- wasmUniq + ret_uniq <- getUniqueM let ret_local = LocalReg ret_uniq ret_cmm_ty lower_CmmUnsafeForeignCall lbl @@ -1379,7 +1379,7 @@ (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg pure $ SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $ - case (# ret_hint, cmmRegWidth platform $ CmmLocal reg #) of + case (# ret_hint, cmmRegWidth $ CmmLocal reg #) of (# SignedHint, W8 #) -> acc_instr `WasmConcat` WasmConst reg_ty 0xFF @@ -1458,7 +1458,7 @@ (i, SomeWasmType ty_reg) <- onCmmLocalReg reg WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i - CmmAssign (CmmGlobal reg) e + CmmAssign (CmmGlobal (GlobalRegUse reg _)) e | BaseReg <- reg -> pure $ WasmStatements WasmNop | Just (sym_global, SomeWasmType ty_reg) <- globalInfoFromCmmGlobalReg ty_word reg -> do @@ -1531,9 +1531,11 @@ lower_CmmGraph lbl g = do ty_word <- wasmWordTypeM platform <- wasmPlatformM + us <- getUniqueSupplyM body <- structuredControl platform + us (\_ -> lower_CmmExpr_Typed lbl ty_word) (lower_CmmActions lbl) g @@ -1551,7 +1553,7 @@ SymDefault -> wasmModifyM $ \s -> s { defaultSyms = - WS.insert + IS.insert (getKey $ getUnique sym) $ defaultSyms s } diff --git a/compiler/GHC/CmmToAsm/Wasm/Types.hs b/compiler/GHC/CmmToAsm/Wasm/Types.hs --- a/compiler/GHC/CmmToAsm/Wasm/Types.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Types.hs @@ -45,7 +45,6 @@ wasmStateM, wasmModifyM, wasmExecM, - wasmUniq, ) where @@ -53,7 +52,7 @@ import Data.ByteString (ByteString) import Data.Coerce import Data.Functor -import qualified GHC.Data.Word64Set as WS +import qualified Data.IntSet as IS import Data.Kind import Data.String import Data.Type.Equality @@ -198,7 +197,7 @@ type SymMap = UniqMap SymName -- | No need to remember the symbols. -type SymSet = WS.Word64Set +type SymSet = IS.IntSet type GlobalInfo = (SymName, SomeWasmType) @@ -428,7 +427,7 @@ WasmCodeGenState { wasmPlatform = platform, - defaultSyms = WS.empty, + defaultSyms = IS.empty, funcTypes = emptyUniqMap, funcBodies = emptyUniqMap, @@ -466,10 +465,18 @@ wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w () wasmModifyM = coerce . modify +wasmEvalM :: WasmCodeGenM w a -> WasmCodeGenState w -> a +wasmEvalM (WasmCodeGenM s) = evalState s + wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w wasmExecM (WasmCodeGenM s) = execState s -wasmUniq :: WasmCodeGenM w Unique -wasmUniq = wasmStateM $ - \s@WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of - (u, us) -> (# u, s {wasmUniqSupply = us} #) +instance MonadUnique (WasmCodeGenM w) where + getUniqueSupplyM = wasmGetsM wasmUniqSupply + getUniqueM = wasmStateM $ + \s@WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of + (u, us) -> (# u, s {wasmUniqSupply = us} #) + getUniquesM = do + u <- getUniqueM + s <- WasmCodeGenM get + pure $ u:(wasmEvalM getUniquesM s) diff --git a/compiler/GHC/CmmToAsm/Wasm/Utils.hs b/compiler/GHC/CmmToAsm/Wasm/Utils.hs --- a/compiler/GHC/CmmToAsm/Wasm/Utils.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Utils.hs @@ -23,7 +23,7 @@ detEltsUFM = sortOn fst . nonDetEltsUFM detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)] -detEltsUniqMap = sortOn fst . nonDetEltsUniqMap +detEltsUniqMap = sortOn fst . nonDetUniqMapToList builderCommas :: (a -> Builder) -> [a] -> Builder builderCommas f xs = mconcat (intersperse ", " (map f xs)) diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs --- a/compiler/GHC/CmmToAsm/X86.hs +++ b/compiler/GHC/CmmToAsm/X86.hs @@ -51,7 +51,6 @@ patchRegsOfInstr = X86.patchRegsOfInstr isJumpishInstr = X86.isJumpishInstr jumpDestsOfInstr = X86.jumpDestsOfInstr - canFallthroughTo = X86.canFallthroughTo patchJumpInstr = X86.patchJumpInstr mkSpillInstr = X86.mkSpillInstr mkLoadInstr = X86.mkLoadInstr 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 @@ -196,10 +196,10 @@ -- Generate location directive dbg <- getDebugBlock (entryLabel block) loc_instrs <- case dblSourceTick =<< dbg of - Just (SourceNote span name) + Just (SourceNote span (LexicalFastString name)) -> do fileId <- getFileId (srcSpanFile span) let line = srcSpanStartLine span; col = srcSpanStartCol span - return $ unitOL $ LOCATION fileId line col name + return $ unitOL $ LOCATION fileId line col (unpackFS name) _ -> return nilOL (mid_instrs,mid_bid) <- stmtsToInstrs id stmts (!tail_instrs,_) <- stmtToInstrs mid_bid tail @@ -228,9 +228,10 @@ addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do config <- getConfig + let platform = ncgPlatform config if ncgDwarfUnwindings config then do lbl <- mkAsmTempLabel <$> getUniqueM - let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) + let unwind = M.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d) return $ toOL [ instr, UNWIND lbl unwind ] else return (unitOL instr) addSpUnwindings instr = return $ unitOL instr @@ -342,7 +343,7 @@ | isFloatType ty -> assignReg_FltCode format reg src | is32Bit && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -407,7 +408,7 @@ getRegisterReg _ (CmmLocal lreg) = getLocalRegReg lreg getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of + = case globalRegMaybe platform $ globalRegUseGlobalReg mid of Just reg -> RegReal $ reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the @@ -480,10 +481,10 @@ -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr -mangleIndexTree platform reg off +mangleIndexTree :: CmmReg -> Int -> CmmExpr +mangleIndexTree reg off = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) + where width = typeWidth (cmmRegType reg) -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. @@ -623,9 +624,9 @@ getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register -getRegister' platform is32Bit (CmmReg reg) +getRegister' _ is32Bit (CmmReg reg) = case reg of - CmmGlobal PicBaseReg + CmmGlobal (GlobalRegUse PicBaseReg _) | is32Bit -> -- on x86_64, we have %rip for PicBaseReg, but it's not -- a full-featured register, it can only be used for @@ -635,7 +636,7 @@ _ -> do let - fmt = cmmTypeFormat (cmmRegType platform reg) + fmt = cmmTypeFormat (cmmRegType reg) format = fmt -- platform <- ncgPlatform <$> getConfig @@ -645,7 +646,7 @@ getRegister' platform is32Bit (CmmRegOff r n) - = getRegister' platform is32Bit $ mangleIndexTree platform r n + = getRegister' platform is32Bit $ mangleIndexTree r n getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e]) = addAlignmentCheck align <$> getRegister' platform is32Bit e @@ -738,7 +739,7 @@ code <- intLoadCode (MOVSxL II32) addr return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement]) | not is32Bit = return $ Any II64 (\dst -> unitOL $ @@ -900,14 +901,10 @@ MO_U_Lt _ -> condIntReg LU x y MO_U_Le _ -> condIntReg LEU x y - MO_F_Add w -> trivialFCode_sse2 w ADD x y - - MO_F_Sub w -> trivialFCode_sse2 w SUB x y - - MO_F_Quot w -> trivialFCode_sse2 w FDIV x y - - MO_F_Mul w -> trivialFCode_sse2 w MUL x y - + MO_F_Add w -> trivialFCode_sse2 w ADD x y + MO_F_Sub w -> trivialFCode_sse2 w SUB x y + MO_F_Quot w -> trivialFCode_sse2 w FDIV x y + MO_F_Mul w -> trivialFCode_sse2 w MUL x y MO_Add rep -> add_code rep x y MO_Sub rep -> sub_code rep x y @@ -1134,7 +1131,14 @@ return (Fixed format result code) +getRegister' _plat _is32Bit (CmmMachOp mop [x, y, z]) = -- ternary MachOps + case mop of + -- Floating point fused multiply-add operations @ ± x*y ± z@ + MO_FMA var w -> genFMA3Code w var x y z + _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)" + (pprMachOp mop) + getRegister' _ _ (CmmLoad mem pk _) | isFloatType pk = do @@ -1301,9 +1305,9 @@ case e of CmmRegOff r n - -> getAmode $ mangleIndexTree platform r n + -> getAmode $ mangleIndexTree r n - CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement] + CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement] | not is32Bit -> return $ Amode (ripRel (litToImm displacement)) nilOL @@ -2437,11 +2441,10 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do +genCCall32 addr conv dest_regs args = do config <- getConfig let platform = ncgPlatform config - args_hints = zip args (argHints ++ repeat NoHint) - prom_args = map (maybePromoteCArg platform W32) args_hints + prom_args = map (maybePromoteCArg platform W32) args -- If the size is smaller than the word, we widen things (see maybePromoteCArg) arg_size_bytes :: CmmType -> Int @@ -2595,11 +2598,10 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do +genCCall64 addr conv dest_regs args = do platform <- getPlatform -- load up the register arguments - let args_hints = zip args (argHints ++ repeat NoHint) - let prom_args = map (maybePromoteCArg platform W32) args_hints + let prom_args = map (maybePromoteCArg platform W32) args let load_args :: [CmmExpr] -> [Reg] -- int regs avail for args @@ -2738,7 +2740,7 @@ <- load_args prom_args (allIntArgRegs platform) (allFPArgRegs platform) nilOL nilOL - let used_regs rs as = reverse (drop (length rs) (reverse as)) + let used_regs rs as = dropTail (length rs) as fregs_used = used_regs fregs (allFPArgRegs platform) aregs_used = used_regs aregs (allIntArgRegs platform) return (stack_args, aregs_used, fregs_used, load_args_code @@ -2837,11 +2839,9 @@ assign_code dest_regs) -maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr -maybePromoteCArg platform wto (arg, hint) - | wfrom < wto = case hint of - SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg] - _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] +maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr +maybePromoteCArg platform wto arg + | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] | otherwise = arg where wfrom = cmmExprWidth platform arg @@ -3176,12 +3176,12 @@ a_code <- getAnyReg a tmp <- getNewRegNat rep let - -- We want the value of b to stay alive across the computation of a. - -- But, we want to calculate a straight into the destination register, + -- We want the value of 'b' to stay alive across the computation of 'a'. + -- But, we want to calculate 'a' straight into the destination register, -- because the instruction only has two operands (dst := dst `op` src). - -- The troublesome case is when the result of b is in the same register - -- as the destination reg. In this case, we have to save b in a - -- new temporary across the computation of a. + -- The troublesome case is when the result of 'b' is in the same register + -- as the destination 'reg'. In this case, we have to save 'b' in a + -- new temporary across the computation of 'a'. code dst | dst `regClashesWithOp` b_op = b_code `appOL` @@ -3198,6 +3198,69 @@ reg `regClashesWithOp` OpReg reg2 = reg == reg2 reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) _ `regClashesWithOp` _ = False + +-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@, +-- with 3 operands (FMA3 instruction set). +genFMA3Code :: Width + -> FMASign + -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register +genFMA3Code w signs x y z = do + + -- For the FMA instruction, we want to compute x * y + z + -- + -- There are three possible instructions we could emit: + -- + -- - fmadd213 z y x, result in x, z can be a memory address + -- - fmadd132 x z y, result in y, x can be a memory address + -- - fmadd231 y x z, result in z, y can be a memory address + -- + -- This suggests two possible optimisations: + -- + -- - OPTIMISATION 1 + -- If one argument is an address, use the instruction that allows + -- a memory address in that position. + -- + -- - OPTIMISATION 2 + -- If one argument is in a fixed register, use the instruction that puts + -- the result in that same register. + -- + -- Currently we follow neither of these optimisations, + -- opting to always use fmadd213 for simplicity. + let rep = floatFormat w + (y_reg, y_code) <- getNonClobberedReg y + (z_reg, z_code) <- getNonClobberedReg z + x_code <- getAnyReg x + y_tmp <- getNewRegNat rep + z_tmp <- getNewRegNat rep + let + fma213 = FMA3 rep signs FMA213 + code dst + | dst == y_reg + , dst == z_reg + = y_code `appOL` + unitOL (MOV rep (OpReg y_reg) (OpReg y_tmp)) `appOL` + z_code `appOL` + unitOL (MOV rep (OpReg z_reg) (OpReg z_tmp)) `appOL` + x_code dst `snocOL` + fma213 (OpReg z_tmp) y_tmp dst + | dst == y_reg + = y_code `appOL` + unitOL (MOV rep (OpReg y_reg) (OpReg z_tmp)) `appOL` + z_code `appOL` + x_code dst `snocOL` + fma213 (OpReg z_reg) y_tmp dst + | dst == z_reg + = y_code `appOL` + z_code `appOL` + unitOL (MOV rep (OpReg z_reg) (OpReg z_tmp)) `appOL` + x_code dst `snocOL` + fma213 (OpReg z_tmp) y_reg dst + | otherwise + = y_code `appOL` + z_code `appOL` + x_code dst `snocOL` + fma213 (OpReg z_reg) y_reg dst + return (Any rep code) ----------- 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 @@ -12,6 +12,7 @@ ( Instr(..) , Operand(..) , PrefetchVariant(..) + , FMAPermutation(..) , JumpDest(..) , getJumpDestBlockId , canShortcut @@ -30,7 +31,6 @@ , mkSpillInstr , mkRegRegMoveInstr , jumpDestsOfInstr - , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr @@ -273,6 +273,10 @@ | CVTSI2SS Format Operand Reg -- I32/I64 to F32 | CVTSI2SD Format Operand Reg -- I32/I64 to F64 + -- | FMA3 fused multiply-add operations. + | FMA3 Format FMASign FMAPermutation Operand Reg Reg + -- src1 (r/m), src2 (r), dst (r) + -- use ADD, SUB, and SQRT for arithmetic. In both cases, operands -- are Operand Reg. @@ -352,7 +356,7 @@ | OpImm Imm -- immediate value | OpAddr AddrMode -- memory reference - +data FMAPermutation = FMA132 | FMA213 | FMA231 -- | Returns which registers are read and written as a (read, written) -- pair. @@ -439,6 +443,8 @@ PDEP _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] PEXT _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] + FMA3 _ _ _ src1 src2 dst -> usageFMA src1 src2 dst + -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) [] LOCK i -> regUsageOfInstr platform i @@ -483,6 +489,15 @@ usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" + -- 3 operand form of FMA instructions. + usageFMA :: Operand -> Reg -> Reg -> RegUsage + usageFMA (OpReg src1) src2 dst + = mkRU [src1, src2, dst] [dst] + usageFMA (OpAddr ea1) src2 dst + = mkRU (use_EA ea1 [src2, dst]) [dst] + usageFMA _ _ _ + = panic "X86.RegInfo.usageFMA: no match" + -- 1 operand form; operand Modified usageM :: Operand -> RegUsage usageM (OpReg reg) = mkRU [reg] [reg] @@ -562,6 +577,8 @@ JMP op regs -> JMP (patchOp op) regs JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl + FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3 + -- literally only support storing the top x87 stack value st(0) X87Store fmt dst -> X87Store fmt (lookupAddr dst) @@ -613,6 +630,8 @@ patch1 insn op = insn $! patchOp op patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a patch2 insn src dst = (insn $! patchOp src) $! patchOp dst + patch3 :: (Operand -> Reg -> Reg -> a) -> Operand -> Reg -> Reg -> a + patch3 insn src1 src2 dst = ((insn $! patchOp src1) $! env src2) $! env dst patchOp (OpReg reg) = OpReg $! env reg patchOp (OpImm imm) = OpImm imm @@ -643,17 +662,6 @@ CALL{} -> True _ -> False -canFallthroughTo :: Instr -> BlockId -> Bool -canFallthroughTo insn bid - = case insn of - JXX _ target -> bid == target - JMP_TBL _ targets _ _ -> all isTargetBid targets - _ -> False - where - isTargetBid target = case target of - Nothing -> True - Just (DestBlockId target) -> target == bid - _ -> False jumpDestsOfInstr :: Instr 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 @@ -74,7 +74,6 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = let platform = ncgPlatform config in - pprProcAlignment config $$ case topInfoTable proc of Nothing -> -- special case for code without info table: @@ -838,6 +837,14 @@ FDIV format op1 op2 -> pprFormatOpOp (text "div") format op1 op2 + FMA3 format var perm op1 op2 op3 + -> let mnemo = case var of + FMAdd -> text "vfmadd" + FMSub -> text "vfmsub" + FNMAdd -> text "vfnmadd" + FNMSub -> text "vfnmsub" + in pprFormatOpRegReg (mnemo <> pprFMAPermutation perm) format op1 op2 op3 + SQRT format op1 op2 -> pprFormatOpReg (text "sqrt") format op1 op2 @@ -968,6 +975,21 @@ pprOperand platform format op2 ] + pprFormatOpRegReg :: Line doc -> Format -> Operand -> Reg -> Reg -> doc + pprFormatOpRegReg name format op1 op2 op3 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprReg platform format op2, + comma, + pprReg platform format op3 + ] + + pprFMAPermutation :: FMAPermutation -> Line doc + pprFMAPermutation FMA132 = text "132" + pprFMAPermutation FMA213 = text "213" + pprFMAPermutation FMA231 = text "231" pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc pprOpOp name format op1 op2 diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -383,7 +383,7 @@ -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprExpr platform $ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit $ CmmInt (toInteger i) w] - where w = cmmRegWidth platform reg + where w = cmmRegWidth reg CmmMachOp mop args -> pprMachOpApp platform mop args @@ -529,6 +529,11 @@ pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc pprMachOpApp' platform mop args = case args of + + -- ternary + args@[_,_,_] -> + pprMachOp_for_C platform mop <> parens (pprWithCommas pprArg args) + -- dyadic [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y @@ -711,13 +716,28 @@ MO_U_Quot _ -> char '/' MO_U_Rem _ -> char '%' - -- & Floating-point operations + -- Floating-point operations MO_F_Add _ -> char '+' MO_F_Sub _ -> char '-' MO_F_Neg _ -> char '-' MO_F_Mul _ -> char '*' MO_F_Quot _ -> char '/' + -- Floating-point fused multiply-add operations + MO_FMA FMAdd w -> + case w of + W32 -> text "fmaf" + W64 -> text "fma" + _ -> + pprTrace "offending mop:" + (text "FMAdd") + (panic $ "PprC.pprMachOp_for_C: FMAdd unsupported" + ++ "at width " ++ show w) + MO_FMA var _width -> + pprTrace "offending mop:" + (text $ "FMA " ++ show var) + (panic $ "PprC.pprMachOp_for_C: should have been handled earlier!") + -- Signed comparisons MO_S_Ge _ -> text ">=" MO_S_Le _ -> text "<=" @@ -1044,9 +1064,11 @@ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2) | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2) | otherwise = mkAssign (pprExpr platform r2) - where mkAssign x = if r1 == CmmGlobal BaseReg - then text "ASSIGN_BaseReg" <> parens x <> semi - else pprReg r1 <> text " = " <> x <> semi + where mkAssign x = + case r1 of + CmmGlobal (GlobalRegUse BaseReg _) -> + text "ASSIGN_BaseReg" <> parens x <> semi + _ -> pprReg r1 <> text " = " <> x <> semi -- --------------------------------------------------------------------- -- Registers @@ -1061,17 +1083,16 @@ -- StgPtr. isFixedPtrReg :: CmmReg -> Bool isFixedPtrReg (CmmLocal _) = False -isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r +isFixedPtrReg (CmmGlobal (GlobalRegUse r _)) = isFixedPtrGlobalReg r -- True if (pprAsPtrReg reg) will give an expression with type StgPtr -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (GlobalRegUse (VanillaReg _) ty)) = isGcPtrType ty -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (GlobalRegUse reg _)) = isFixedPtrGlobalReg reg -- True if this global reg has type StgPtr isFixedPtrGlobalReg :: GlobalReg -> Bool @@ -1085,7 +1106,7 @@ -- (machRepCType (cmmRegType reg)), so it has to be cast. isStrangeTypeReg :: CmmReg -> Bool isStrangeTypeReg (CmmLocal _) = False -isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g +isStrangeTypeReg (CmmGlobal (GlobalRegUse g _)) = isStrangeTypeGlobal g isStrangeTypeGlobal :: GlobalReg -> Bool isStrangeTypeGlobal CCCS = True @@ -1095,10 +1116,10 @@ isStrangeTypeGlobal r = isFixedPtrGlobalReg r strangeRegType :: CmmReg -> Maybe SDoc -strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") -strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") -strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") -strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") +strangeRegType (CmmGlobal (GlobalRegUse CCCS _)) = Just (text "struct CostCentreStack_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentTSO _)) = Just (text "struct StgTSO_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentNursery _)) = Just (text "struct bdescr_ *") +strangeRegType (CmmGlobal (GlobalRegUse BaseReg _)) = Just (text "struct StgRegTable_ *") strangeRegType _ = Nothing -- pprReg just prints the register name. @@ -1106,16 +1127,16 @@ pprReg :: CmmReg -> SDoc pprReg r = case r of CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global + CmmGlobal (GlobalRegUse global _ ) -> pprGlobalReg global pprAsPtrReg :: CmmReg -> SDoc -pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" +pprAsPtrReg (CmmGlobal (GlobalRegUse (VanillaReg n) ty)) + = warnPprTrace (not $ isGcPtrType ty) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg pprGlobalReg :: GlobalReg -> SDoc pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n <> text ".w" + VanillaReg n -> char 'R' <> int n <> text ".w" -- pprGlobalReg prints a VanillaReg as a .w regardless -- Example: R1.w = R1.w & (-0x8UL); -- JMP_(*R1.p); 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 -import GHC.Prelude +import GHC.Prelude hiding ( head ) import GHC.Llvm import GHC.CmmToLlvm.Base @@ -27,7 +27,8 @@ import GHC.Cmm.Dataflow.Collections import GHC.Utils.BufHandle -import GHC.Driver.Session +import GHC.Driver.DynFlags +import GHC.Platform ( platformArch, Arch(..) ) import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable @@ -36,7 +37,8 @@ import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) -import Data.Maybe ( fromMaybe, catMaybes, isNothing ) +import Data.List.NonEmpty ( head ) +import Data.Maybe ( fromMaybe, catMaybes ) import System.IO -- ----------------------------------------------------------------------------- @@ -66,13 +68,11 @@ "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." - - when (isNothing mb_ver) $ do - let doWarn = llvmCgDoWarn cfg - when doWarn $ putMsg logger $ - "Failed to detect LLVM version!" $$ - "Make sure LLVM is installed correctly." $$ - "We will try though..." + let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X + let major_ver = head . llvmVersionNE $ ver + when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $ + "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> + "You are using LLVM version: " <> text (llvmVersionStr ver) -- HACK: the Nothing case here is potentially wrong here but we -- currently don't use the LLVM version to guide code generation @@ -91,7 +91,7 @@ llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a llvmCodeGen' cfg cmm_stream = do -- Preamble - renderLlvm header + renderLlvm (llvmHeader cfg) (llvmHeader cfg) ghcInternalFunctions cmmMetaLlvmPrelude @@ -99,20 +99,23 @@ a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens -- Declare aliases for forward references - renderLlvm . pprLlvmData cfg =<< generateExternDecls + decls <- generateExternDecls + renderLlvm (pprLlvmData cfg decls) + (pprLlvmData cfg decls) -- Postamble cmmUsedLlvmGens return a - where - header :: SDoc - header = - let target = llvmCgLlvmTarget cfg - llvmCfg = llvmCgLlvmConfig cfg - in (text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"") - $+$ (text "target triple = \"" <> text target <> text "\"") +llvmHeader :: IsDoc doc => LlvmCgConfig -> doc +llvmHeader cfg = + let target = llvmCgLlvmTarget cfg + llvmCfg = llvmCgLlvmConfig cfg + in lines_ + [ text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"" + , text "target triple = \"" <> text target <> text "\"" ] + where getDataLayout :: LlvmConfig -> String -> String getDataLayout config target = case lookup target (llvmTargets config) of @@ -121,6 +124,8 @@ text "Target:" <+> text target $$ hang (text "Available targets:") 4 (vcat $ map (text . fst) $ llvmTargets config) +{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> SDoc #-} +{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () llvmGroupLlvmGens cmm = do @@ -156,10 +161,11 @@ = funInsert l ty regGlobal _ = pure () mapM_ regGlobal gs - gss' <- mapM aliasify $ gs + gss' <- mapM aliasify gs cfg <- getConfig - renderLlvm $ pprLlvmData cfg (concat gss', concat tss) + renderLlvm (pprLlvmData cfg (concat gss', concat tss)) + (pprLlvmData cfg (concat gss', concat tss)) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM () @@ -175,12 +181,12 @@ -- generate llvm code from cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm - -- pretty print - (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC - - -- Output, note down used variables - renderLlvm (vcat docs) - mapM_ markUsedVar $ concat ivars + -- pretty print - print as we go, since we produce HDocs, we know + -- no nesting state needs to be maintained for the SDocs. + forM_ llvmBC (\decl -> do + (hdoc, sdoc) <- pprLlvmCmmDecl decl + renderLlvm (hdoc $$ empty) (sdoc $$ empty) + ) cmmLlvmGen _ = return () @@ -204,7 +210,8 @@ -- name. Nothing -> [ MetaStr name ] cfg <- getConfig - renderLlvm $ ppLlvmMetas cfg metas + renderLlvm (ppLlvmMetas cfg metas) + (ppLlvmMetas cfg metas) -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary @@ -229,4 +236,7 @@ lmUsed = LMGlobal lmUsedVar (Just usedArray) if null ivars then return () - else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], []) + else do + cfg <- getConfig + renderLlvm (pprLlvmData cfg ([lmUsed], [])) + (pprLlvmData cfg ([lmUsed], [])) 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 @@ -44,10 +44,10 @@ import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Cmm hiding ( succ ) -import GHC.Cmm.Utils (regsOverlap) +import GHC.Cmm.Utils (globalRegsOverlap) import GHC.Utils.Outputable as Outp import GHC.Platform import GHC.Types.Unique.FM @@ -194,8 +194,8 @@ -- all use the same real regs on X86-64 (XMM registers). -- classes = NE.groupBy sharesClass fprLive - sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers - norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family + sharesClass a b = globalRegsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers + norm x = fpr_ctor x 1 -- get the first register of the family -- For each class, we just have to fill missing registers numbers. We use -- the constructor of the greatest register to build padding registers. @@ -260,7 +260,7 @@ , envConfig :: !LlvmCgConfig -- ^ Configuration for LLVM code gen , envLogger :: !Logger -- ^ Logger , envOutput :: BufHandle -- ^ Output buffer - , envTag :: !Char -- ^ Tag for creating unique values + , envMask :: !Char -- ^ Mask for creating unique values , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type @@ -292,12 +292,12 @@ instance MonadUnique LlvmM where getUniqueSupplyM = do - tag <- getEnv envTag - liftIO $! mkSplitUniqSupply tag + mask <- getEnv envMask + liftIO $! mkSplitUniqSupply mask getUniqueM = do - tag <- getEnv envTag - liftIO $! uniqFromTag tag + mask <- getEnv envMask + liftIO $! uniqFromMask mask -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a @@ -318,7 +318,7 @@ , envConfig = cfg , envLogger = logger , envOutput = out - , envTag = 'n' + , envMask = 'n' , envFreshMeta = MetaId 0 , envUniqMeta = emptyUFM } @@ -371,13 +371,13 @@ liftIO $ putDumpFileMaybe logger flag hdr fmt doc -- | Prints the given contents to the output handle -renderLlvm :: Outp.SDoc -> LlvmM () -renderLlvm sdoc = do +renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM () +renderLlvm hdoc sdoc = do -- Write to output ctx <- llvmCgContext <$> getConfig out <- getEnv envOutput - liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc + liftIO $ Outp.bPutHDoc out ctx hdoc -- Dump, if requested dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc @@ -428,7 +428,7 @@ let n' = fsLit n decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret FixedArgs (tysToParams args) Nothing - renderLlvm $ ppLlvmFunctionDecl decl + renderLlvm (ppLlvmFunctionDecl decl) (ppLlvmFunctionDecl decl) funInsert n' (LMFunction decl) -- ---------------------------------------------------------------------------- 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 @@ -207,7 +207,7 @@ castV <- lift $ mkLocalVar ty ve <- exprToVarW e statement $ Assignment castV $ Cast LM_Uitofp ve width - statement $ Store castV dstV Nothing + statement $ Store castV dstV Nothing [] genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ @@ -263,12 +263,12 @@ AMO_Or -> LAO_Or AMO_Xor -> LAO_Xor retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst - statement $ Store retVar dstVar Nothing + statement $ Store retVar dstVar Nothing [] genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst) v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned - statement $ Store v1 dstV Nothing + statement $ Store v1 dstV Nothing [] genCall (PrimTarget (MO_Cmpxchg _width)) [dst] [addr, old, new] = runStmtsDecls $ do @@ -282,7 +282,7 @@ retVar <- doExprW (LMStructU [targetTy,i1]) $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst retVar' <- doExprW targetTy $ ExtractV retVar 0 - statement $ Store retVar' dstVar Nothing + statement $ Store retVar' dstVar Nothing [] genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar @@ -292,7 +292,7 @@ ptrExpr = Cast LM_Inttoptr addrVar ptrTy ptrVar <- doExprW ptrTy ptrExpr resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst) - statement $ Store resVar dstV Nothing + statement $ Store resVar dstV Nothing [] genCall (PrimTarget (MO_AtomicWrite _width mem_ord)) [] [addr, val] = runStmtsDecls $ do addrVar <- exprToVarW addr @@ -353,8 +353,8 @@ retH <- doExprW width $ Cast LM_Trunc retShifted width dstRegL <- getCmmRegW (CmmLocal dstL) dstRegH <- getCmmRegW (CmmLocal dstH) - statement $ Store retL dstRegL Nothing - statement $ Store retH dstRegH Nothing + statement $ Store retL dstRegL Nothing [] + statement $ Store retH dstRegH Nothing [] genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do let width = widthToLlvmInt w @@ -385,9 +385,9 @@ dstRegL <- getCmmRegW (CmmLocal dstL) dstRegH <- getCmmRegW (CmmLocal dstH) dstRegC <- getCmmRegW (CmmLocal dstC) - statement $ Store retL dstRegL Nothing - statement $ Store retH dstRegH Nothing - statement $ Store retC dstRegC Nothing + statement $ Store retL dstRegL Nothing [] + statement $ Store retH dstRegH Nothing [] + statement $ Store retC dstRegC Nothing [] -- MO_U_QuotRem2 is another case we handle by widening the registers to double -- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The @@ -421,8 +421,8 @@ retRem <- narrow retExtRem dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) dstRegR <- lift $ getCmmReg (CmmLocal dstR) - statement $ Store retDiv dstRegQ Nothing - statement $ Store retRem dstRegR Nothing + statement $ Store retDiv dstRegQ Nothing [] + statement $ Store retRem dstRegR Nothing [] -- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from -- which we need to extract the actual values. @@ -529,7 +529,7 @@ vreg <- getCmmRegW (CmmLocal creg) if retTy == pLower (getVarType vreg) then do - statement $ Store v1 vreg Nothing + statement $ Store v1 vreg Nothing [] doReturn else do let ty = pLower $ getVarType vreg @@ -541,7 +541,7 @@ ++ " returned type!" v2 <- doExprW ty $ Cast op v1 ty - statement $ Store v2 vreg Nothing + statement $ Store v2 vreg Nothing [] doReturn -- | Generate a call to an LLVM intrinsic that performs arithmetic operation @@ -570,8 +570,8 @@ (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width dstRegV <- getCmmReg (CmmLocal dstV) dstRegO <- getCmmReg (CmmLocal dstO) - let storeV = Store value dstRegV Nothing - storeO = Store overflow dstRegO Nothing + let storeV = Store value dstRegV Nothing [] + storeO = Store overflow dstRegO Nothing [] return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) genCallWithOverflow _ _ _ _ = panic "genCallExtract: wrong ForeignTarget or number of arguments" @@ -636,7 +636,7 @@ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] let retV' = singletonPanic "genCallSimpleCast" retVs' - let s2 = Store retV' dstV Nothing + let s2 = Store retV' dstV Nothing [] let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2 @@ -668,7 +668,7 @@ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] let retV' = singletonPanic "genCallSimpleCast2" retVs' - let s2 = Store retV' dstV Nothing + let s2 = Store retV' dstV Nothing [] let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2 @@ -1098,16 +1098,16 @@ -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vreg Nothing + let s2 = Store v vreg Nothing [] return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty - let s2 = mkStore v vreg NaturallyAligned + let s2 = mkStore v vreg NaturallyAligned [] return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do - let s1 = Store vval vreg Nothing + let s1 = Store vval vreg Nothing [] return (stmts `snocOL` s1, top2) @@ -1143,12 +1143,12 @@ -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr -> AlignmentSpec +genStore_fast :: CmmExpr -> GlobalRegUse -> Int -> CmmExpr -> AlignmentSpec -> LlvmM StmtData genStore_fast addr r n val alignment = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r + meta <- getTBAARegMeta (globalRegUseGlobalReg r) let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) case isPointer grt && rem == 0 of True -> do @@ -1158,7 +1158,7 @@ case pLower grt == getVarType vval of -- were fine True -> do - let s3 = MetaStmt meta $ mkStore vval ptr alignment + let s3 = mkStore vval ptr alignment meta return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -1166,7 +1166,7 @@ False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = MetaStmt meta $ mkStore vval ptr' alignment + let s4 = mkStore vval ptr' alignment meta return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) @@ -1189,17 +1189,17 @@ -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = MetaStmt meta $ mkStore v vaddr alignment + let s2 = mkStore v vaddr alignment meta return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do - let s1 = MetaStmt meta $ mkStore vval vaddr alignment + let s1 = mkStore vval vaddr alignment meta return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord platform -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = MetaStmt meta $ mkStore vval vptr alignment + let s2 = mkStore vval vptr alignment meta return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> @@ -1209,9 +1209,9 @@ text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$ text "Var:" <+> ppVar cfg vaddr) -mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement -mkStore vval vptr alignment = - Store vval vptr align +mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement +mkStore vval vptr alignment metas = + Store vval vptr align metas where ty = pLower (getVarType vptr) align = case alignment of @@ -1388,8 +1388,7 @@ -> genMachOp opt op exprs CmmRegOff r i - -> do platform <- getPlatform - exprToVar $ expandCmmReg platform (r, i) + -> exprToVar $ expandCmmReg (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" @@ -1470,6 +1469,9 @@ MO_F_Sub _ -> panicOp MO_F_Mul _ -> panicOp MO_F_Quot _ -> panicOp + + MO_FMA _ _ -> panicOp + MO_F_Eq _ -> panicOp MO_F_Ne _ -> panicOp MO_F_Ge _ -> panicOp @@ -1554,7 +1556,7 @@ -- | Handle CmmMachOp expressions -- This is a specialised method that handles Global register manipulations like -- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] +genMachOp_fast :: EOption -> MachOp -> GlobalRegUse -> Int -> [CmmExpr] -> LlvmM ExprData genMachOp_fast opt op r n e = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) @@ -1653,6 +1655,8 @@ MO_F_Mul _ -> genBinMach LM_MO_FMul MO_F_Quot _ -> genBinMach LM_MO_FDiv + MO_FMA _ _ -> panicOp + MO_And _ -> genBinMach LM_MO_And MO_Or _ -> genBinMach LM_MO_Or MO_Xor _ -> genBinMach LM_MO_Xor @@ -1786,10 +1790,29 @@ panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" ++ "with two arguments! (" ++ show op ++ ")" --- More than two expression, invalid! -genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!" +genMachOp_slow _opt op [x, y, z] = case op of + MO_FMA var _ -> triLlvmOp getVarType (FMAOp var) + _ -> panicOp + where + triLlvmOp ty op = do + platform <- getPlatform + runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + vz <- exprToVarW z + if | getVarType vx == getVarType vy + , getVarType vx == getVarType vz + -> doExprW (ty vx) $ op vx vy vz + | otherwise + -> pprPanic "triLlvmOp types" (pdoc platform x $$ pdoc platform y $$ pdoc platform z) + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered" + ++ "with three arguments! (" ++ show op ++ ")" +-- More than three expressions, invalid! +genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!" + + -- | Handle CmmLoad expression. genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData @@ -1822,12 +1845,12 @@ -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType +genLoad_fast :: Atomic -> CmmExpr -> GlobalRegUse -> Int -> CmmType -> AlignmentSpec -> LlvmM ExprData genLoad_fast atomic e r n ty align = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r + meta <- getTBAARegMeta (globalRegUseGlobalReg r) let ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) case isPointer grt && rem == 0 of @@ -1917,10 +1940,11 @@ -- "funPrologue" to allocate it on the stack. getCmmReg (CmmGlobal g) - = do onStack <- checkStackReg g + = do let r = globalRegUseGlobalReg g + onStack <- checkStackReg r platform <- getPlatform if onStack - then return (lmGlobalRegVar platform g) + then return (lmGlobalRegVar platform r) else pprPanic "getCmmReg: Cmm register " $ ppr g <> text " not stack-allocated!" @@ -1930,10 +1954,10 @@ getCmmRegVal reg = case reg of CmmGlobal g -> do - onStack <- checkStackReg g + onStack <- checkStackReg (globalRegUseGlobalReg g) platform <- getPlatform if onStack then loadFromStack else do - let r = lmGlobalRegArg platform g + let r = lmGlobalRegArg platform (globalRegUseGlobalReg g) return (r, getVarType r, nilOL) _ -> loadFromStack where loadFromStack = do @@ -2064,7 +2088,7 @@ let (newv, stmts) = allocReg reg varInsert un (pLower $ getVarType newv) return stmts - CmmGlobal r -> do + CmmGlobal (GlobalRegUse r _) -> do let reg = lmGlobalRegVar platform r arg = lmGlobalRegArg platform r ty = (pLower . getVarType) reg @@ -2072,7 +2096,7 @@ rval = if isLive r then arg else trash alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 markStackReg r - return $ toOL [alloc, Store rval reg Nothing] + return $ toOL [alloc, Store rval reg Nothing []] return (concatOL stmtss `snocOL` jumpToEntry, []) where @@ -2107,8 +2131,8 @@ let allRegs = activeStgRegs platform loads <- forM allRegs $ \r -> if -- load live registers - | r `elem` alwaysLive -> loadExpr r - | r `elem` live -> loadExpr r + | r `elem` alwaysLive -> loadExpr (GlobalRegUse r (globalRegSpillType platform r)) + | r `elem` live -> loadExpr (GlobalRegUse r (globalRegSpillType platform r)) -- load all non Floating-Point Registers | not (isFPR r) -> loadUndef r -- load padding Floating-Point Registers @@ -2152,9 +2176,9 @@ -- | Expand CmmRegOff -expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr -expandCmmReg platform (reg, off) - = let width = typeWidth (cmmRegType platform reg) +expandCmmReg :: (CmmReg, Int) -> CmmExpr +expandCmmReg (reg, off) + = let width = typeWidth (cmmRegType reg) voff = CmmLit $ CmmInt (fromIntegral off) width in CmmMachOp (MO_Add width) [CmmReg reg, voff] 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 @@ -89,7 +89,6 @@ align = case sec of Section CString _ -> if (platformArch platform == ArchS390X) then Just 2 else Just 1 - Section Data _ -> Just $ platformWordSizeInBytes platform _ -> Nothing const = if sectionProtection sec == ReadOnlySection then Constant else Global diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -38,7 +38,7 @@ -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite] -rewrites = [rewriteSymType, rewriteAVX, rewriteCall] +rewrites = [rewriteSymType, rewriteAVX, rewriteCall, rewriteJump] type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString @@ -121,6 +121,29 @@ replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l where removePlt = replaceOnce (B.pack "@plt") (B.pack "") + appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) + +-- | This rewrites bl and b jump inst to avoid creating PLT entries for +-- functions on loongarch64, because there is no separate call instruction +-- for function calls in loongarch64. Also, this replacement will load +-- the function address from the GOT, which is resolved to point to the +-- real address of the function. +rewriteJump :: Rewrite +rewriteJump platform l + | not isLoongArch64 = Nothing + | isBL l = Just $ replaceJump "bl" "$ra" "$ra" l + | isB l = Just $ replaceJump "b" "$zero" "$t0" l + | otherwise = Nothing + where + isLoongArch64 = platformArch platform == ArchLoongArch64 + isBL = B.isPrefixOf (B.pack "bl\t") + isB = B.isPrefixOf (B.pack "b\t") + + replaceJump jump rd rj l = + appendInsn ("jirl" ++ "\t" ++ rd ++ ", " ++ rj ++ ", 0") $ removeBracket $ + replaceOnce (B.pack (jump ++ "\t%plt(")) (B.pack ("la\t" ++ rj ++ ", ")) l + where + removeBracket = replaceOnce (B.pack ")") (B.pack "") appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) -- | @replaceOnce match replace bs@ replaces the first occurrence of the 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 @@ -26,22 +26,28 @@ -- -- | Pretty print LLVM data code -pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc +pprLlvmData :: IsDoc doc => LlvmCgConfig -> LlvmData -> doc pprLlvmData cfg (globals, types) = - let ppLlvmTys (LMAlias a) = ppLlvmAlias a + let ppLlvmTys (LMAlias a) = line $ ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types globals' = ppLlvmGlobals cfg globals - in types' $+$ globals' + in types' $$ globals' +{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc #-} +{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +-- The HDoc we return is used to produce the final LLVM file, with the +-- SDoc being returned alongside for use when @Opt_D_dump_llvm@ is set +-- as we can't (currently) dump HDocs. +pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (HDoc, SDoc) pprLlvmCmmDecl (CmmData _ lmdata) = do opts <- getConfig - return (vcat $ map (pprLlvmData opts) lmdata, []) + return ( vcat $ map (pprLlvmData opts) lmdata + , vcat $ map (pprLlvmData opts) lmdata) pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) = do let lbl = case mb_info of @@ -92,7 +98,8 @@ (Just $ LMBitc (LMStaticPointer defVar) i8Ptr) - return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', []) + return ( vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun'] + , vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun']) -- | The section we are putting info tables and their entry code into, should 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 @@ -37,16 +37,16 @@ BaseReg -> ptrGlobal $ "Base" ++ suf Sp -> ptrGlobal $ "Sp" ++ suf Hp -> ptrGlobal $ "Hp" ++ suf - VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf - VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf - VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf - VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf - VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf - VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf - VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf - VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf - VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf - VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf + VanillaReg 1 -> wordGlobal $ "R1" ++ suf + VanillaReg 2 -> wordGlobal $ "R2" ++ suf + VanillaReg 3 -> wordGlobal $ "R3" ++ suf + VanillaReg 4 -> wordGlobal $ "R4" ++ suf + VanillaReg 5 -> wordGlobal $ "R5" ++ suf + VanillaReg 6 -> wordGlobal $ "R6" ++ suf + VanillaReg 7 -> wordGlobal $ "R7" ++ suf + VanillaReg 8 -> wordGlobal $ "R8" ++ suf + VanillaReg 9 -> wordGlobal $ "R9" ++ suf + VanillaReg 10 -> wordGlobal $ "R10" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $ "F1" ++ suf FloatReg 2 -> floatGlobal $ "F2" ++ suf @@ -129,8 +129,8 @@ -- | Get the correct TBAA metadata information for this register type getTBAA :: GlobalReg -> Unique -getTBAA BaseReg = baseN -getTBAA Sp = stackN -getTBAA Hp = heapN -getTBAA (VanillaReg _ _) = rxN -getTBAA _ = topN +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _) = rxN +getTBAA _ = topN diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs --- a/compiler/GHC/Core/LateCC.hs +++ b/compiler/GHC/Core/LateCC.hs @@ -26,7 +26,7 @@ import GHC.Core.Opt.Monad import GHC.Core.Utils (mkTick) import GHC.Types.Id -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Logger import GHC.Utils.Outputable @@ -117,7 +117,7 @@ | otherwise = doBndr' env bndr rhs --- We want to put the cost centra below the lambda as we only care about executions of the RHS. +-- We want to put the cost centre below the lambda as we only care about executions of the RHS. doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs doBndr' env bndr rhs = do 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 @@ -35,6 +35,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Panic.Plain import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) import Data.List ( mapAccumL ) @@ -270,11 +271,11 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where - ids = filter isId bndrs env_alt | DataAlt dc <- con + , let ids = filter isId bndrs , CprType arity cpr <- scrut_ty - , arity == 0 -- See Note [Dead code may contain type confusions] + , assert (arity == 0 ) True = case unpackConFieldsCpr dc cpr of AllFieldsSame field_cpr | let sig = mkCprSig 0 field_cpr @@ -283,7 +284,7 @@ | let sigs = zipWith (mkCprSig . idArity) ids field_cprs -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) | otherwise - = extendSigEnvAllSame env ids topCprSig + = env (rhs_ty, rhs') = cprAnal env_alt rhs -- @@ -430,43 +431,6 @@ (id', rhs', env') = cprAnalBind env id rhs {- -Note [Dead code may contain type confusions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In T23862, we have a nested case match that looks like this - - data CheckSingleton (check :: Bool) where - Checked :: CheckSingleton True - Unchecked :: CheckSingleton False - data family Result (check :: Bool) a - data instance Result True a = CheckedResult a - newtype instance Result True a = UncheckedResult a - - case m () of Checked co1 -> - case m () of Unchecked co2 -> - case ((\_ -> True) - |> .. UncheckedResult .. - |> sym co2 - |> co1) :: Result True (Bool -> Bool) of - CheckedResult f -> CheckedResult (f True) - -Clearly, the innermost case is dead code, because the `Checked` and `Unchecked` -cases are apart. -However, both constructors introduce mutually contradictory coercions `co1` and -`co2` along which GHC generates a type confusion: - - 1. (\_ -> True) :: Bool -> Bool - 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool) - 3. |> ... sym co1 ... :: Result check (Bool -> Bool) - 4. |> ... co2 ... :: Result True (Bool -> Bool) - -Note that we started with a function, injected into `Result` via a newtype -instance and then match on it with a datatype instance. - -We have to handle this case gracefully in `cprAnalAlt`, where for the innermost -case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that -abstracts the function `(\_ -> True)` with arity 1. -In this case, don't pretend we know anything about the fields of `CheckedResult`! - Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: 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 @@ -16,39 +16,42 @@ import GHC.Prelude -import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it + import GHC.Core -import GHC.Core.Multiplicity ( scaledThing ) -import GHC.Utils.Outputable -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Basic -import Data.List ( mapAccumL ) import GHC.Core.DataCon -import GHC.Types.ForeignCall ( isSafeForeignCall ) -import GHC.Types.Id import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type -import GHC.Core.Predicate( isClassPred ) +import GHC.Core.Predicate( isEqualityClass, isCTupleClass ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.TyCo.Compare ( eqType ) +import GHC.Core.Multiplicity ( scaledThing ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.Maybe +import GHC.Core.Opt.WorkWrap.Utils + import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) + import GHC.Types.Unique.Set import GHC.Types.Unique.MemoFun import GHC.Types.RepType +import GHC.Types.ForeignCall ( isSafeForeignCall ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Outputable +import Data.List ( mapAccumL ) + {- ************************************************************************ * * @@ -403,7 +406,7 @@ anticipateANF :: CoreExpr -> Card -> Card anticipateANF e n | exprIsTrivial e = n -- trivial expr won't have a binding - | Just Unlifted <- typeLevity_maybe (exprType e) + | definitelyUnliftedType (exprType e) , not (isAbs n && exprOkForSpeculation e) = case_bind n | otherwise = let_bind n where @@ -1089,8 +1092,8 @@ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' (de_div rhs_env) - `orElse` (rhs_dmds, rhs') + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity + rhs_dmds (de_div rhs_env) rhs' sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) @@ -1273,7 +1276,9 @@ * Ordinary bindings: idArity f. Why idArity arguments? Because that's a conservative estimate of how many arguments we must feed a function before it does anything interesting with - them. Also it elegantly subsumes the trivial RHS and PAP case. + them. Also it elegantly subsumes the trivial RHS and PAP case. E.g. for + f = g + we want to use a threshold arity based on g, not 0! idArity is /at least/ the number of manifest lambdas, but might be higher for PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). @@ -1498,7 +1503,7 @@ So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S>b` where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments -are unboxed (recursively). The wrapper for `indexError` won't /acutally/ +are unboxed (recursively). The wrapper for `indexError` won't /actually/ unbox them (because their polymorphic type doesn't allow that) but when demand-analysing /callers/, we'll behave as if that call needs the args unboxed. @@ -1781,39 +1786,6 @@ that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`. -Note [Do not unbox class dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never unbox class dictionaries in worker/wrapper. - -1. INLINABLE functions - If we have - f :: Ord a => [a] -> Int -> a - {-# INLINABLE f #-} - and we worker/wrapper f, we'll get a worker with an INLINABLE pragma - (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), - which can still be specialised by the type-class specialiser, something like - fw :: Ord a => [a] -> Int# -> a - - BUT if f is strict in the Ord dictionary, we might unpack it, to get - fw :: (a->a->Bool) -> [a] -> Int# -> a - and the type-class specialiser can't specialise that. An example is #6056. - - Historical note: #14955 describes how I got this fix wrong the first time. - I got aware of the issue in T5075 by the change in boxity of loop between - demand analysis runs. - -2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur - occur without INLINABLE, when we use -fexpose-all-unfoldings and - -fspecialise-aggressively to do vigorous cross-module specialisation. - -3. #18421 found that unboxing a dictionary can also make the worker less likely - to inline; the inlining heuristics seem to prefer to inline a function - applied to a dictionary over a function applied to a bunch of functions. - -TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing -a raft of higher-order functions isn't a huge win anyway -- you really want to -specialise the function. - Note [Worker argument budget] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 'finaliseArgBoxities' we don't want to generate workers with zillions of @@ -1947,22 +1919,39 @@ positiveTopBudget :: Budgets -> Bool positiveTopBudget (MkB n _) = n >= 0 -finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence - -> Maybe ([Demand], CoreExpr) -finaliseArgBoxities env fn arity rhs div - | arity > count isId bndrs -- Can't find enough binders - = Nothing -- This happens if we have f = g - -- Then there are no binders; we don't worker/wrapper; and we - -- simply want to give f the same demand signature as g +finaliseArgBoxities :: AnalEnv -> Id -> Arity + -> [Demand] -> Divergence + -> CoreExpr -> ([Demand], CoreExpr) +finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs - | otherwise -- NB: arity is the threshold_arity, which might be less than + -- Check for an OPAQUE function: see Note [OPAQUE pragma] + -- In that case, trim off all boxity info from argument demands + -- and demand info on lambda binders + -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + | isOpaquePragma (idInlinePragma fn) + , let trimmed_rhs_dmds = map trimBoxity rhs_dmds + = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + + -- Check that we have enough visible binders to match the + -- threshold arity; if not, we won't do worker/wrapper + -- This happens if we have simply {f = g} or a PAP {f = h 13} + -- we simply want to give f the same demand signature as g + -- How can such bindings arise? Perhaps from {-# NOLINE[2] f #-}, + -- or if the call to `f` is currently not-applied (map f xs). + -- It's a bit of a corner case. Anyway for now we pass on the + -- unadulterated demands from the RHS, without any boxity trimming. + | threshold_arity > count isId bndrs + = (rhs_dmds, rhs) + + -- The normal case + | otherwise -- NB: threshold_arity might be less than -- manifest arity for join points = -- pprTrace "finaliseArgBoxities" ( -- vcat [text "function:" <+> ppr fn -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - Just (arg_dmds', add_demands arg_dmds' rhs) - -- add_demands: we must attach the final boxities to the lambda-binders + (arg_dmds', set_lam_dmds arg_dmds' rhs) + -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where @@ -1979,30 +1968,16 @@ (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take arity $ - [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty) - | bndr <- bndrs - , isRuntimeVar bndr, let bndr_ty = idType bndr ] - - get_dmd :: Id -> Type -> Demand - get_dmd bndr bndr_ty - | isClassPred bndr_ty = trimBoxity dmd - -- See Note [Do not unbox class dictionaries] - -- NB: 'ty' has not been normalised, so this will (rightly) - -- catch newtype dictionaries too. - -- NB: even for bottoming functions, don't unbox dictionaries - - | is_bot_fn = unboxDeeplyDmd dmd - -- See Note [Boxity for bottoming functions], case (B) - - | is_opaque = trimBoxity dmd - -- See Note [OPAQUE pragma] - -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + arg_triples = take threshold_arity $ + [ (idType bndr, NotMarkedStrict, get_dmd bndr) + | bndr <- bndrs, isRuntimeVar bndr ] - | otherwise = dmd + get_dmd :: Id -> Demand + get_dmd bndr + | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], + | otherwise = dmd -- case (B) where - dmd = idDemandInfo bndr - is_opaque = isOpaquePragma (idInlinePragma fn) + dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2059,13 +2034,18 @@ | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - add_demands :: [Demand] -> CoreExpr -> CoreExpr + set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr -- Attach the demands to the outer lambdas of this expression - add_demands [] e = e - add_demands (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (add_demands (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e) - add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e) + set_lam_dmds (dmd:dmds) (Lam v e) + | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) + | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) + set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co + -- This case happens for an OPAQUE function, which may look like + -- f = (\x y. blah) |> co + -- We give it strictness but no boxity (#22502) + set_lam_dmds _ e = e + -- In the OPAQUE case, the list of demands at this point might be + -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). finaliseLetBoxity :: AnalEnv @@ -2101,6 +2081,12 @@ -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal -> DontUnbox + | doNotUnbox ty + -> DontUnbox -- See Note [Do not unbox class dictionaries] + -- NB: 'ty' has not been normalised, so this will (rightly) + -- catch newtype dictionaries too. + -- NB: even for bottoming functions, don't unbox dictionaries + | DefinitelyRecursive <- ae_rec_dc env dc -- See Note [Which types are unboxed?] -- and Note [Demand analysis for recursive data constructors] @@ -2110,6 +2096,76 @@ -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args) (dataConRepStrictness dc) dmds) + + +doNotUnbox :: Type -> Bool +-- Do not unbox class dictionaries, except equality classes and tuples +-- Note [Do not unbox class dictionaries] +doNotUnbox arg_ty + = case tyConAppTyCon_maybe arg_ty of + Just tc | Just cls <- tyConClass_maybe tc + -> not (isEqualityClass cls || isCTupleClass cls) + -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries] + + _ -> False + +{- Note [Do not unbox class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never unbox class dictionaries in worker/wrapper. + +1. INLINABLE functions + If we have + f :: Ord a => [a] -> Int -> a + {-# INLINABLE f #-} + and we worker/wrapper f, we'll get a worker with an INLINABLE pragma + (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), + which can still be specialised by the type-class specialiser, something like + fw :: Ord a => [a] -> Int# -> a + + BUT if f is strict in the Ord dictionary, we might unpack it, to get + fw :: (a->a->Bool) -> [a] -> Int# -> a + and the type-class specialiser can't specialise that. An example is #6056. + + Historical note: #14955 describes how I got this fix wrong the first time. + I got aware of the issue in T5075 by the change in boxity of loop between + demand analysis runs. + +2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur + occur without INLINABLE, when we use -fexpose-all-unfoldings and + -fspecialise-aggressively to do vigorous cross-module specialisation. + +3. #18421 found that unboxing a dictionary can also make the worker less likely + to inline; the inlining heuristics seem to prefer to inline a function + applied to a dictionary over a function applied to a bunch of functions. + +TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing +a raft of higher-order functions isn't a huge win anyway -- you really want to +specialise the function. + +Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398) + f :: (% Eq a, Show a %) => blah + with -fdicts-strict it is great to unbox to + $wf :: Eq a => Show a => blah + (where I have written out the currying explicitly). Now we can specialise + $wf on the Eq or Show dictionary. Nothing is lost. + + And something is gained. It is possible that `f` will look like this: + f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)... + where there is a recurive call to `f`, or to another function that takes the + same tuple dictionary, but where the tuple is built from the components of + `d`. The Simplier does not fix this. But if we unpacked the dictionary + we'd get + $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %) + in ...f @a (% sel1 d, sel2 d %) + and all the tuple building and taking apart will disappear. + +Wrinkle (DNB2): we /do/ wnat to unbox equality dictionaries, + for (~), (~~), and Coercible (#23398). Their payload is a single unboxed + coercion. We never want to specialise on `(t1 ~ t2)`. All that would do is + to make a copy of the function's RHS with a particular coercion. Unlike + normal class methods, that does not unlock any new optimisation + opportunities in the specialised RHS. +-} {- ********************************************************************* * * 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 @@ -28,7 +28,7 @@ import GHC.Core.FVs import GHC.Core.Type -import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted) ) +import GHC.Types.Basic ( RecFlag(..), isRec ) import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var @@ -618,7 +618,7 @@ | isJoinId bndr = isRec is_rec -- Joins are one-shot iff non-recursive - | Just Unlifted <- typeLevity_maybe (idType bndr) + | definitelyUnliftedType (idType bndr) = True -- Preserve let-can-float invariant, see Note [noFloatInto considerations] | otherwise 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 @@ -14,6 +14,7 @@ import GHC.Core import GHC.Core.Unfold +import GHC.Core.Opt.Simplify.Inline import GHC.Builtin.Types ( unitDataConId ) import GHC.Types.Id import GHC.Types.Var.Env diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -10,7 +10,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Driver.Config.Core.Lint ( endPass ) @@ -77,9 +77,9 @@ , mg_loc = loc , mg_rdr_env = rdr_env }) = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars - uniq_tag = 's' + uniq_mask = 's' - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod name_ppr_ctx loc $ do { hsc_env' <- getHscEnv ; all_passes <- withPlugins (hsc_plugins hsc_env') 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 @@ -1752,13 +1752,12 @@ cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) new_lvl vs - = do { us <- getUniqueSupplyM - ; let (subst', vs') = cloneBndrs subst us vs + = do { (subst', vs') <- cloneBndrs subst vs -- N.B. We are not moving the body of the case, merely its case -- binders. Consequently we should *not* set le_ctxt_lvl and -- le_join_ceil. See Note [Setting levels when floating -- single-alternative cases]. - env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' + ; let env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' , le_subst = subst' , le_env = foldl' add_id id_env (vs `zip` vs') } @@ -1773,13 +1772,13 @@ cloneLetVars is_rec env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) dest_lvl vs - = do { us <- getUniqueSupplyM - ; let vs1 = map zap vs + = do { let vs1 = map zap vs -- See Note [Zapping the demand info] - (subst', vs2) = case is_rec of - NonRecursive -> cloneBndrs subst us vs1 - Recursive -> cloneRecIdBndrs subst us vs1 - prs = vs `zip` vs2 + ; (subst', vs2) <- case is_rec of + NonRecursive -> cloneBndrs subst vs1 + Recursive -> cloneRecIdBndrs subst vs1 + + ; let prs = vs `zip` vs2 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 , le_subst = subst' , le_env = foldl' add_id id_env prs } 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,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, LambdaCase #-} #if __GLASGOW_HASKELL__ < 905 {-# LANGUAGE PatternSynonyms #-} #endif @@ -25,13 +25,14 @@ import GHC.Prelude -import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug ) import GHC.Core import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold +import GHC.Core.Opt.Simplify.Inline import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils @@ -1477,7 +1478,8 @@ scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _ e@(Lit {}) = return (nullUsage, e) scExpr' env (Tick t e) = do (usg, e') <- scExpr env e - return (usg, Tick t e') + (usg_t, t') <- scTickish env t + return (combineUsage usg usg_t, Tick t' e') scExpr' env (Cast e co) = do (usg, e') <- scExpr env e return (usg, mkCast e' (scSubstCo env co)) -- Important to use mkCast here @@ -1536,6 +1538,17 @@ ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } +-- | Substitute the free variables captured by a breakpoint. +-- Variables are dropped if they have a non-variable substitution, like in +-- 'GHC.Opt.Specialise.specTickish'. +scTickish :: ScEnv -> CoreTickish -> UniqSM (ScUsage, CoreTickish) +scTickish env = \case + Breakpoint ext i fv -> do + (usg, fv') <- unzip <$> mapM (\ v -> scExpr env (Var v)) fv + pure (combineUsages usg, Breakpoint ext i [v | Var v <- fv']) + t@ProfNote {} -> pure (nullUsage, t) + t@HpcTick {} -> pure (nullUsage, t) + t@SourceNote {} -> pure (nullUsage, t) {- Note [Do not specialise evals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -10,7 +10,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) @@ -3484,9 +3484,8 @@ cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id]) cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs - = do { us <- getUniqueSupplyM - ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us bndrs - env' = env { se_subst = subst' } + = do { (subst', bndrs') <- Core.cloneRecIdBndrs subst bndrs + ; let env' = env { se_subst = subst' } ; return (env', bndrs') } newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr) 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 @@ -20,6 +20,8 @@ import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.SimpleOpt +import GHC.Data.FastString + import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info @@ -68,9 +70,7 @@ wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram wwTopBinds ww_opts us top_binds - = initUs_ us $ do - top_binds' <- mapM (wwBind ww_opts) top_binds - return (concat top_binds') + = initUs_ us $ concatMapM (wwBind ww_opts) top_binds {- ************************************************************************ @@ -821,7 +821,7 @@ NoInline _ -> inl_act fn_inl_prag _ -> inl_act wrap_prag - work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" + work_prag = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" , inl_inline = fn_inline_spec , inl_sat = Nothing , inl_act = work_act @@ -889,7 +889,7 @@ mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl , inl_act = fn_act , inl_rule = rule_info }) rules - = InlinePragma { inl_src = SourceText "{-# INLINE" + = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" , inl_sat = Nothing , inl_inline = fn_inl 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 @@ -213,12 +213,11 @@ -- Clone and prepare arg_vars of the original fun RHS -- See Note [Freshen WW arguments] -- and Note [Zap IdInfo on worker args] - ; uniq_supply <- getUniqueSupplyM ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars) empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs) zapped_arg_vars = map zap_var arg_vars - (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars - res_ty' = substTyUnchecked subst res_ty + ; (subst, cloned_arg_vars) <- cloneBndrs empty_subst zapped_arg_vars + ; let res_ty' = substTyUnchecked subst res_ty init_str_marks = map (const NotMarkedStrict) cloned_arg_vars ; (useful1, work_args_str, wrap_fn_str, fn_args) diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -19,7 +19,8 @@ import GHC.Prelude import GHC.Core -import GHC.Core.Utils +import GHC.Core.Utils ( exprType, findDefault, isJoinBind + , exprIsTickedString_maybe ) import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon @@ -48,7 +49,7 @@ import GHC.Data.FastString import GHC.Platform ( Platform ) import GHC.Platform.Ways -import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) import GHC.Utils.Outputable import GHC.Utils.Monad @@ -573,19 +574,6 @@ -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- -getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg --- A (non-erased) trivial CoreArg corresponds to an atomic StgArg. --- CoreArgs may not immediately look trivial, e.g., `case e of {}` or --- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. --- Good thing we can just call `trivial_expr_fold` here. -getStgArgFromTrivialArg e - | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8, - = StgLitArg (LitString s) -- where we used to treat strings as valid StgArgs - | otherwise - = trivial_expr_fold StgVarArg StgLitArg panic panic e - where - panic = pprPanic "getStgArgFromTrivialArg" (ppr e) - coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs [] = return ([], []) @@ -598,29 +586,42 @@ = do { (args', ts) <- coreToStgArgs args ; return (StgVarArg coercionTokenId : args', ts) } +coreToStgArgs (Tick t e : args) + = assert (not (tickishIsCode t)) $ + do { (args', ts) <- coreToStgArgs (e : args) + ; let !t' = coreToStgTick (exprType e) t + ; return (args', t':ts) } + coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, ticks) <- coreToStgArgs args - -- We know that `arg` must be trivial, but it may contain Ticks. - -- Example from test case `decodeMyStack`: - -- $ @... ((src Data.Tuple.snd) @Int @[..]) - -- Note that unfortunately the Tick is not at the top. - -- So we'll traverse the expression twice: - -- * Once with `stripTicksT` (which collects *all* ticks from the expression) - -- * and another time with `getStgArgFromTrivialArg`. - -- Since the argument is trivial, the only place the Tick can occur is - -- somehow wrapping a variable (give or take type args, as above). + arg' <- coreToStgExpr arg + let + (aticks, arg'') = stripStgTicksTop tickishFloatable arg' + stg_arg = case arg'' of + StgApp v [] -> StgVarArg v + StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) + StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'') + + -- WARNING: what if we have an argument like (v `cast` co) + -- where 'co' changes the representation type? + -- (This really only happens if co is unsafe.) + -- Then all the getArgAmode stuff in CgBindery will set the + -- cg_rep of the CgIdInfo based on the type of v, rather + -- than the type of 'co'. + -- This matters particularly when the function is a primop + -- or foreign call. + -- Wanted: a better solution than this hacky warning + platform <- getPlatform - let arg_ty = exprType arg - ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg) - arg' = getStgArgFromTrivialArg arg - arg_rep = typePrimRep arg_ty - stg_arg_rep = typePrimRep (stgArgType arg') + let + arg_rep = typePrimRep (exprType arg) + stg_arg_rep = typePrimRep (stgArgType stg_arg) bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) - massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) - warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ()) - - return (arg' : stg_args, ticks' ++ ticks) + warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $ + return (stg_arg : stg_args, ticks ++ aticks) coreToStgTick :: Type -- type of the ticked expression -> CoreTickish @@ -690,7 +691,7 @@ return (mkStgRhs bndr new_rhs) -- Represents the RHS of a binding for use with mk(Top)StgRhs. -data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks +data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas. @@ -698,7 +699,7 @@ coreToPreStgRhs expr = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do { body' <- coreToStgExpr body - ; return (PreStgRhs args' body') } + ; return (PreStgRhs args' body' (exprType body)) } where (args, body) = myCollectBinders expr args' = filterStgBinders args @@ -712,13 +713,13 @@ { coreToStg_platform = platform , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs - } this_mod ccs bndr (PreStgRhs bndrs rhs) + } this_mod ccs bndr (PreStgRhs bndrs rhs typ) | not (null bndrs) = -- The list of arguments is non-empty, so not CAF ( StgRhsClosure noExtFieldSilent dontCareCCS ReEntrant - bndrs rhs + bndrs rhs typ , ccs ) -- After this point we know that `bndrs` is empty, @@ -729,19 +730,19 @@ = -- CorePrep does this right, but just to make sure assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) (ppr bndr $$ ppr con $$ ppr args) - ( StgRhsCon dontCareCCS con mn ticks args, ccs ) + ( StgRhsCon dontCareCCS con mn ticks args typ, ccs ) -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. | opt_AutoSccsOnIndividualCafs = ( StgRhsClosure noExtFieldSilent caf_ccs - upd_flag [] rhs + upd_flag [] rhs typ , collectCC caf_cc caf_ccs ccs ) | otherwise = ( StgRhsClosure noExtFieldSilent all_cafs_ccs - upd_flag [] rhs + upd_flag [] rhs typ , ccs ) where @@ -765,12 +766,12 @@ -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. mkStgRhs :: Id -> PreStgRhs -> StgRhs -mkStgRhs bndr (PreStgRhs bndrs rhs) +mkStgRhs bndr (PreStgRhs bndrs rhs typ) | not (null bndrs) = StgRhsClosure noExtFieldSilent currentCCS ReEntrant - bndrs rhs + bndrs rhs typ -- After this point we know that `bndrs` is empty, -- so this is not a function binding @@ -781,15 +782,15 @@ StgRhsClosure noExtFieldSilent currentCCS ReEntrant -- ignored for LNE - [] rhs + [] rhs typ | StgConApp con mn args _ <- unticked_rhs - = StgRhsCon currentCCS con mn ticks args + = StgRhsCon currentCCS con mn ticks args typ | otherwise = StgRhsClosure noExtFieldSilent currentCCS - upd_flag [] rhs + upd_flag [] rhs typ where (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs 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 @@ -314,7 +314,7 @@ | Just file <- ml_hs_file mod_loc = tick (span1 file) | otherwise = tick (span1 "???") where tick span = Tick $ SourceNote span $ - renderWithContext defaultSDocContext $ ppr name + LexicalFastString $ mkFastString $ renderWithContext defaultSDocContext $ ppr name span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 {- @@ -1648,13 +1648,17 @@ most code paths anyway, we get to turn the unknown eval in the callee into a known call at the call site. -However, we must be very careful not to speculate recursive calls! -Doing so might well change termination behavior. +Very Nasty Wrinkle +We must be very careful not to speculate recursive calls! Doing so +might well change termination behavior. + That comes up in practice for DFuns, which are considered ok-for-spec, because they always immediately return a constructor. -Not so if you speculate the recursive call, as #20836 shows: +See Note [NON-BOTTOM-DICTS invariant] in GHC.Core. +But not so if you speculate the recursive call, as #20836 shows: + class Foo m => Foo m where runFoo :: m a -> m a newtype Trans m a = Trans { runTrans :: m a } @@ -1711,17 +1715,6 @@ It is also similar to Note [Do not strictify a DFun's parameter dictionaries], where marking recursive DFuns (of undecidable *instances*) strict in dictionary *parameters* leads to quite the same change in termination as above. - -Note [Controlling Speculative Evaluation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Most of the time, speculative evaluation has a positive effect on performance, -but we have found a case where speculative evaluation of dictionary functions -leads to a performance regression #25284. - -Therefore we have some flags to control it. See the optimization section in -the User's Guide for the description of these flags and when to use them. - -} data FloatingBind @@ -1796,15 +1789,7 @@ where is_hnf = exprIsHNF rhs is_strict = isStrUsedDmd dmd - cfg = cpe_config env - - ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs - -- See Note [Controlling Speculative Evaluation] - call_ok_for_spec x - | is_rec_call x = False - | not (cp_specEval cfg) = False - | not (cp_specEvalDFun cfg) && isDFunId x = False - | otherwise = True + ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) emptyFloats :: Floats @@ -1992,12 +1977,6 @@ , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr) -- ^ Convert some numeric literals (Integer, Natural) into their final -- Core form. - - , cp_specEval :: !Bool - -- ^ Whether to perform speculative evaluation - -- See Note [Controlling Speculative Evaluation] - , cp_specEvalDFun :: !Bool - -- ^ Whether to perform speculative evaluation on DFuns } data CorePrepEnv @@ -2129,9 +2108,9 @@ { tcm_tyvar = \env tv -> return (lookup_tce_tv env tv) , tcm_covar = \env cv -> return (lookup_tce_cv env cv) , tcm_hole = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole) - , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv - then return (subst_tv_bndr env tcv) - else return (subst_cv_bndr env tcv) + , tcm_tycobinder = \env tcv _vis k -> if isTyVar tcv + then uncurry k (subst_tv_bndr env tcv) + else uncurry k (subst_cv_bndr env tcv) , tcm_tycon = \tc -> return tc } subst_ty :: CpeTyCoEnv -> Type -> Identity Type diff --git a/compiler/GHC/Data/Graph/Collapse.hs b/compiler/GHC/Data/Graph/Collapse.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Collapse.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Data.Graph.Collapse + ( PureSupernode(..) + , Supernode(..) + , collapseInductiveGraph + , VizCollapseMonad(..) + , NullCollapseViz(..) + , runNullCollapse + , MonadUniqSM(..) + ) +where + +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Data.List (delete, union, insert, intersect) +import Data.Semigroup + +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Inductive.Graph +import GHC.Types.Unique.Supply +import GHC.Utils.Panic + + +{-| +Module : GHC.Data.Graph.Collapse +Description : Implement the "collapsing" algorithm Hecht and Ullman + +A control-flow graph is reducible if and only if it is collapsible +according to the definition of Hecht and Ullman (1972). This module +implements the collapsing algorithm of Hecht and Ullman, and if it +encounters a graph that is not collapsible, it splits nodes until the +graph is fully collapsed. It then reports what nodes (if any) had to +be split in order to collapse the graph. The information is used +upstream to node-split Cmm graphs. + +The module uses the inductive graph representation cloned from the +Functional Graph Library (Hackage package `fgl`, modules +`GHC.Data.Graph.Inductive.*`.) + +-} + +-- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman +-- (1972). Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +-- https://doi.org/10.1137/0201014 + + +------------------ Graph-splitting monad ----------------------- + +-- | If you want to visualize the graph-collapsing algorithm, create +-- an instance of monad `VizCollapseMonad`. Each step in the +-- algorithm is announced to the monad as a side effect. If you don't +-- care about visualization, you would use the `NullCollapseViz` +-- monad, in which these operations are no-ops. + +class (Monad m) => MonadUniqSM m where + liftUniqSM :: UniqSM a -> m a + +class (MonadUniqSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where + consumeByInGraph :: Node -> Node -> gr s () -> m () + splitGraphAt :: gr s () -> LNode s -> m () + finalGraph :: gr s () -> m () + + + +-- | The identity monad as a `VizCollapseMonad`. Use this monad when +-- you want efficiency in graph collapse. +newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqSM a } + deriving (Functor, Applicative, Monad, MonadUnique) + +instance MonadUniqSM NullCollapseViz where + liftUniqSM = NullCollapseViz + +instance (Graph gr, Supernode s NullCollapseViz) => + VizCollapseMonad NullCollapseViz gr s where + consumeByInGraph _ _ _ = return () + splitGraphAt _ _ = return () + finalGraph _ = return () + +runNullCollapse :: NullCollapseViz a -> UniqSM a +runNullCollapse = unNCV + + +------------------ Utility functions on graphs ----------------------- + + +-- | Tell if a `Node` has a single predecessor. +singlePred :: Graph gr => gr a b -> Node -> Bool +singlePred gr n + | ([_], _, _, _) <- context gr n = True + | otherwise = False + +-- | Use this function to extract information about a `Node` that you +-- know is in a `Graph`. It's like `match` from `Graph`, but it must +-- succeed. +forceMatch :: (Graph gr) + => Node -> gr s b -> (Context s b, gr s b) +forceMatch node g = case match node g of (Just c, g') -> (c, g') + _ -> panicDump node g + where panicDump :: Graph gr => Node -> gr s b -> any + panicDump k _g = + panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k + +-- | Rewrite the label of a given node. +updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b +updateNode relabel node g = (preds, n, relabel this, succs) & g' + where ((preds, n, this, succs), g') = forceMatch node g + + +-- | Test if a graph has but a single node. +singletonGraph :: Graph gr => gr a b -> Bool +singletonGraph g = case labNodes g of [_] -> True + _ -> False + + +---------------- Supernodes ------------------------------------ + +-- | A "supernode" stands for a collection of one or more nodes (basic +-- blocks) that have been coalesced by the Hecht-Ullman algorithm. +-- A collection in a supernode constitutes a /reducible/ subgraph of a +-- control-flow graph. (When an entire control-flow graph is collapsed +-- to a single supernode, the flow graph is reducible.) +-- +-- The idea of node splitting is to collapse a control-flow graph down +-- to a single supernode, then materialize (``inflate'') the reducible +-- equivalent graph from that supernode. The `Supernode` class +-- defines only the methods needed to collapse; rematerialization is +-- the responsiblity of the client. +-- +-- During the Hecht-Ullman algorithm, every supernode has a unique +-- entry point, which is given by `superLabel`. But this invariant is +-- not guaranteed by the class methods and is not a law of the class. +-- The `mapLabels` function rewrites all labels that appear in a +-- supernode (both definitions and uses). The `freshen` function +-- replaces every appearance of a /defined/ label with a fresh label. +-- (Appearances include both definitions and uses.) +-- +-- Laws: +-- @ +-- superLabel (n <> n') == superLabel n +-- blocks (n <> n') == blocks n `union` blocks n' +-- mapLabels f (n <> n') = mapLabels f n <> mapLabels f n' +-- mapLabels id == id +-- mapLabels (f . g) == mapLabels f . mapLabels g +-- @ +-- +-- (We expect `freshen` to distribute over `<>`, but because of +-- the fresh names involved, formulating a precise law is a bit +-- challenging.) + +class (Semigroup node) => PureSupernode node where + superLabel :: node -> Label + mapLabels :: (Label -> Label) -> (node -> node) + +class (MonadUnique m, PureSupernode node) => Supernode node m where + freshen :: node -> m node + + -- ghost method + -- blocks :: node -> Set Block + +------------------ Functions specific to the algorithm ----------------------- + +-- | Merge two nodes, return new graph plus list of nodes that newly have a single +-- predecessor. This function implements transformation $T_2$ from +-- the Hecht and Ullman paper (merge the node into its unique +-- predecessor). It then also removes self-edges (transformation $T_1$ from +-- the Hecht and Ullman paper). There is no need for a separate +-- implementation of $T_1$. +-- +-- `consumeBy v u g` returns the graph that results when node v is +-- consumed by node u in graph g. Both v and u are replaced with a new node u' +-- with these properties: +-- +-- LABELS(u') = LABELS(u) `union` LABELS(v) +-- SUCC(u') = SUCC(u) `union` SUCC(v) - { u } +-- every node that previously points to u now points to u' +-- +-- It also returns a list of nodes in the result graph that +-- are *newly* single-predecessor nodes. + +consumeBy :: (DynGraph gr, PureSupernode s) + => Node -> Node -> gr s () -> (gr s (), [Node]) +consumeBy toNode fromNode g = + assert (toPreds == [((), fromNode)]) $ + (newGraph, newCandidates) + where ((toPreds, _, to, toSuccs), g') = forceMatch toNode g + ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g' + context = ( fromPreds -- by construction, can't have `toNode` + , fromNode + , from <> to + , delete ((), fromNode) toSuccs `union` fromSuccs + ) + newGraph = context & g'' + newCandidates = filter (singlePred newGraph) changedNodes + changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs) + +-- | Split a given node. The node is replaced with a collection of replicas, +-- one for each predecessor. After the split, every predecessor +-- points to a unique replica. +split :: forall gr s b m . (DynGraph gr, Supernode s m) + => Node -> gr s b -> m (gr s b) +split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes + where ((preds, _, this, succs), g') = forceMatch node g + newNodes :: [((b, Node), Node)] + newNodes = zip preds [maxNode+1..] + (_, maxNode) = nodeRange g + thisLabel = superLabel this + addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b) + addReplica g ((b, pred), newNode) = do + newSuper <- freshen this + return $ add newSuper + where add newSuper = + updateNode (thisLabel `replacedWith` superLabel newSuper) pred $ + ([(b, pred)], newNode, newSuper, succs) & g + +replacedWith :: PureSupernode s => Label -> Label -> s -> s +replacedWith old new = mapLabels (\l -> if l == old then new else l) + + +-- | Does a list have more than one element? (in constant time). +isMultiple :: [a] -> Bool +isMultiple [] = False +isMultiple [_] = False +isMultiple (_:_:_) = True + +-- | Find a candidate for splitting by finding a node that has multiple predecessors. + +anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a +anySplittable g = case splittable of + n : _ -> n + [] -> panic "anySplittable found no splittable nodes" + where splittable = filter (isMultiple . pre g . fst) $ labNodes g + splittable :: [LNode a] + + +------------------ The collapsing algorithm ----------------------- + +-- | Using the algorithm of Hecht and Ullman (1972), collapse a graph +-- into a single node, splitting nodes as needed. Record +-- visualization events in monad `m`. +collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s) + => gr s () -> m (gr s ()) +collapseInductiveGraph g = drain g worklist + where worklist :: [[Node]] -- nodes with exactly one predecessor + worklist = [filter (singlePred g) $ nodes g] + + drain g [] = if singletonGraph g then finalGraph g >> return g + else let (n, super) = anySplittable g + in do splitGraphAt g (n, super) + collapseInductiveGraph =<< split n g + drain g ([]:nss) = drain g nss + drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g + in do consumeByInGraph n (theUniquePred n) g + drain g' (ns':ns:nss) + where theUniquePred n + | ([(_, p)], _, _, _) <- context g n = p + | otherwise = + panic "node claimed to have a unique predecessor; it doesn't" diff --git a/compiler/GHC/Data/Graph/Inductive/Graph.hs b/compiler/GHC/Data/Graph/Inductive/Graph.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Inductive/Graph.hs @@ -0,0 +1,643 @@ +-- (c) 1999-2005 by Martin Erwig (see copyright at bottom) +-- | Static and Dynamic Inductive Graphs +-- +-- Code is from Hackage `fgl` package version 5.7.0.3 +-- +module GHC.Data.Graph.Inductive.Graph ( + -- * General Type Defintions + -- ** Node and Edge Types + Node,LNode,UNode, + Edge,LEdge,UEdge, + -- ** Types Supporting Inductive Graph View + Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp, + Path,LPath(..),UPath, + -- * Graph Type Classes + -- | We define two graph classes: + -- + -- Graph: static, decomposable graphs. + -- Static means that a graph itself cannot be changed + -- + -- DynGraph: dynamic, extensible graphs. + -- Dynamic graphs inherit all operations from static graphs + -- but also offer operations to extend and change graphs. + -- + -- Each class contains in addition to its essential operations those + -- derived operations that might be overwritten by a more efficient + -- implementation in an instance definition. + -- + -- Note that labNodes is essentially needed because the default definition + -- for matchAny is based on it: we need some node from the graph to define + -- matchAny in terms of match. Alternatively, we could have made matchAny + -- essential and have labNodes defined in terms of ufold and matchAny. + -- However, in general, labNodes seems to be (at least) as easy to define + -- as matchAny. We have chosen labNodes instead of the function nodes since + -- nodes can be easily derived from labNodes, but not vice versa. + Graph(..), + DynGraph(..), + -- * Operations + order, + size, + -- ** Graph Folds and Maps + ufold,gmap,nmap,emap,nemap, + -- ** Graph Projection + nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem, + -- ** Graph Construction and Destruction + insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge, + insNodes,insEdges,delNodes,delEdges, + buildGr,mkUGraph, + -- ** Subgraphs + gfiltermap,nfilter,labnfilter,labfilter,subgraph, + -- ** Graph Inspection + context,lab,neighbors,lneighbors, + suc,pre,lsuc,lpre, + out,inn,outdeg,indeg,deg, + hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj, + equal, + -- ** Context Inspection + node',lab',labNode',neighbors',lneighbors', + suc',pre',lpre',lsuc', + out',inn',outdeg',indeg',deg', + -- * Pretty-printing + prettify, + prettyPrint, + -- * Ordering of Graphs + OrdGr(..) +) where + +import GHC.Prelude + +import Control.Arrow (first) +import Data.Function (on) +import qualified Data.IntSet as IntSet +import Data.List (delete, groupBy, sort, sortBy, (\\)) +import Data.Maybe (fromMaybe, isJust) + +import GHC.Utils.Panic + +-- | Unlabeled node +type Node = Int +-- | Labeled node +type LNode a = (Node,a) +-- | Quasi-unlabeled node +type UNode = LNode () + +-- | Unlabeled edge +type Edge = (Node,Node) +-- | Labeled edge +type LEdge b = (Node,Node,b) +-- | Quasi-unlabeled edge +type UEdge = LEdge () + +-- | Unlabeled path +type Path = [Node] +-- | Labeled path +newtype LPath a = LP { unLPath :: [LNode a] } + +instance (Show a) => Show (LPath a) where + show (LP xs) = show xs + +instance (Eq a) => Eq (LPath a) where + (LP []) == (LP []) = True + (LP ((_,x):_)) == (LP ((_,y):_)) = x==y + (LP _) == (LP _) = False + +instance (Ord a) => Ord (LPath a) where + compare (LP []) (LP []) = EQ + compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y + compare _ _ = panic "LPath: cannot compare two empty paths" + +-- | Quasi-unlabeled path +type UPath = [UNode] + +-- | Labeled links to or from a 'Node'. +type Adj b = [(b,Node)] +-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'. +-- +-- In other words, this captures all information regarding the +-- specified 'Node' within a graph. +type Context a b = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node +type MContext a b = Maybe (Context a b) +-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest +-- of the 'Graph'. +type Decomp g a b = (MContext a b,g a b) +-- | The same as 'Decomp', only more sure of itself. +type GDecomp g a b = (Context a b,g a b) + +-- | Unlabeled context. +type UContext = ([Node],Node,[Node]) +-- | Unlabeled decomposition. +type UDecomp g = (Maybe UContext,g) + +-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes' +class Graph gr where + {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-} + + -- | An empty 'Graph'. + empty :: gr a b + + -- | True if the given 'Graph' is empty. + isEmpty :: gr a b -> Bool + + -- | Decompose a 'Graph' into the 'MContext' found for the given node and the + -- remaining 'Graph'. + match :: Node -> gr a b -> Decomp gr a b + + -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's. + -- + -- For graphs that are also instances of 'DynGraph', @mkGraph ns + -- es@ should be equivalent to @('insEdges' es . 'insNodes' ns) + -- 'empty'@. + mkGraph :: [LNode a] -> [LEdge b] -> gr a b + + -- | A list of all 'LNode's in the 'Graph'. + labNodes :: gr a b -> [LNode a] + + -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node' + -- and the remaining 'Graph'. + matchAny :: gr a b -> GDecomp gr a b + matchAny g = case labNodes g of + [] -> panic "Match Exception, Empty Graph" + (v,_):_ | (Just c,g') <- match v g -> (c,g') + _ -> panic "This can't happen: failed to match node in graph" + + + -- | The number of 'Node's in a 'Graph'. + noNodes :: gr a b -> Int + noNodes = length . labNodes + + -- | The minimum and maximum 'Node' in a 'Graph'. + nodeRange :: gr a b -> (Node,Node) + nodeRange g + | isEmpty g = panic "nodeRange of empty graph" + | otherwise = (minimum vs, maximum vs) + where + vs = nodes g + + -- | A list of all 'LEdge's in the 'Graph'. + labEdges :: gr a b -> [LEdge b] + labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) [] + +class (Graph gr) => DynGraph gr where + -- | Merge the 'Context' into the 'DynGraph'. + -- + -- Context adjacencies should only refer to either a Node already + -- in a graph or the node in the Context itself (for loops). + -- + -- Behaviour is undefined if the specified 'Node' already exists + -- in the graph. + (&) :: Context a b -> gr a b -> gr a b + + +-- | The number of nodes in the graph. An alias for 'noNodes'. +order :: (Graph gr) => gr a b -> Int +order = noNodes + +-- | The number of edges in the graph. +-- +-- Note that this counts every edge found, so if you are +-- representing an unordered graph by having each edge mirrored this +-- will be incorrect. +-- +-- If you created an unordered graph by either mirroring every edge +-- (including loops!) or using the @undir@ function in +-- "Data.Graph.Inductive.Basic" then you can safely halve the value +-- returned by this. +size :: (Graph gr) => gr a b -> Int +size = length . labEdges + +-- | Fold a function over the graph by recursively calling 'match'. +ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c +ufold f u g + | isEmpty g = u + | otherwise = f c (ufold f u g') + where + (c,g') = matchAny g + +-- | Map a function over the graph by recursively calling 'match'. +gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d +gmap f = ufold (\c->(f c&)) empty +{-# NOINLINE [0] gmap #-} + +-- | Map a function over the 'Node' labels in a graph. +nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b +nmap f = gmap (\(p,v,l,s)->(p,v,f l,s)) +{-# NOINLINE [0] nmap #-} + +-- | Map a function over the 'Edge' labels in a graph. +emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c +emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) + where + map1 g = map (first g) +{-# NOINLINE [0] emap #-} + +-- | Map functions over both the 'Node' and 'Edge' labels in a graph. +nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d +nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s)) + where + fe' = map (first fe) +{-# NOINLINE [0] nemap #-} + +-- | List all 'Node's in the 'Graph'. +nodes :: (Graph gr) => gr a b -> [Node] +nodes = map fst . labNodes + +-- | List all 'Edge's in the 'Graph'. +edges :: (Graph gr) => gr a b -> [Edge] +edges = map toEdge . labEdges + +-- | Drop the label component of an edge. +toEdge :: LEdge b -> Edge +toEdge (v,w,_) = (v,w) + +-- | Add a label to an edge. +toLEdge :: Edge -> b -> LEdge b +toLEdge (v,w) l = (v,w,l) + +-- | The label in an edge. +edgeLabel :: LEdge b -> b +edgeLabel (_,_,l) = l + +-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'. +newNodes :: (Graph gr) => Int -> gr a b -> [Node] +newNodes i g + | isEmpty g = [0..i-1] + | otherwise = [n+1..n+i] + where + (_,n) = nodeRange g + +-- | 'True' if the 'Node' is present in the 'Graph'. +gelem :: (Graph gr) => Node -> gr a b -> Bool +gelem v = isJust . fst . match v + +-- | Insert a 'LNode' into the 'Graph'. +insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b +insNode (v,l) = (([],v,l,[])&) +{-# NOINLINE [0] insNode #-} + +-- | Insert a 'LEdge' into the 'Graph'. +insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b +insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g' + where + (mcxt,g') = match v g + (pr,_,la,su) = fromMaybe + (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v)) + mcxt +{-# NOINLINE [0] insEdge #-} + +-- | Remove a 'Node' from the 'Graph'. +delNode :: (Graph gr) => Node -> gr a b -> gr a b +delNode v = delNodes [v] + +-- | Remove an 'Edge' from the 'Graph'. +-- +-- NOTE: in the case of multiple edges, this will delete /all/ such +-- edges from the graph as there is no way to distinguish between +-- them. If you need to delete only a single such edge, please use +-- 'delLEdge'. +delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b +delEdge (v,w) g = case match v g of + (Nothing,_) -> g + (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g' + +-- | Remove an 'LEdge' from the 'Graph'. +-- +-- NOTE: in the case of multiple edges with the same label, this +-- will only delete the /first/ such edge. To delete all such +-- edges, please use 'delAllLedge'. +delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b +delLEdge = delLEdgeBy delete + +-- | Remove all edges equal to the one specified. +delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b +delAllLEdge = delLEdgeBy (filter . (/=)) + +delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b) + -> LEdge b -> gr a b -> gr a b +delLEdgeBy f (v,w,b) g = case match v g of + (Nothing,_) -> g + (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g' + +-- | Insert multiple 'LNode's into the 'Graph'. +insNodes :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b +insNodes vs g = foldl' (flip insNode) g vs +{-# INLINABLE insNodes #-} + +-- | Insert multiple 'LEdge's into the 'Graph'. +insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b +insEdges es g = foldl' (flip insEdge) g es +{-# INLINABLE insEdges #-} + +-- | Remove multiple 'Node's from the 'Graph'. +delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b +delNodes vs g = foldl' (snd .: flip match) g vs + +-- | Remove multiple 'Edge's from the 'Graph'. +delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b +delEdges es g = foldl' (flip delEdge) g es + +-- | Build a 'Graph' from a list of 'Context's. +-- +-- The list should be in the order such that earlier 'Context's +-- depend upon later ones (i.e. as produced by @'ufold' (:) []@). +buildGr :: (DynGraph gr) => [Context a b] -> gr a b +buildGr = foldr (&) empty + +-- | Build a quasi-unlabeled 'Graph'. +mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () () +mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es) + where + labUEdges = map (`toLEdge` ()) + labUNodes = map (flip (,) ()) + +-- | Build a graph out of the contexts for which the predicate is +-- satisfied by recursively calling 'match'. +gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d +gfiltermap f = ufold (maybe id (&) . f) empty + +-- | Returns the subgraph only containing the labelled nodes which +-- satisfy the given predicate. +labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b +labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr + +-- | Returns the subgraph only containing the nodes which satisfy the +-- given predicate. +nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b +nfilter f = labnfilter (f . fst) + +-- | Returns the subgraph only containing the nodes whose labels +-- satisfy the given predicate. +labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b +labfilter f = labnfilter (f . snd) + +-- | Returns the subgraph induced by the supplied nodes. +subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b +subgraph vs = let vs' = IntSet.fromList vs + in nfilter (`IntSet.member` vs') + +-- | Find the context for the given 'Node'. Causes an error if the 'Node' is +-- not present in the 'Graph'. +context :: (Graph gr) => gr a b -> Node -> Context a b +context g v = fromMaybe (panic ("Match Exception, Node: "++show v)) + (fst (match v g)) + +-- | Find the label for a 'Node'. +lab :: (Graph gr) => gr a b -> Node -> Maybe a +lab g v = fmap lab' . fst $ match v g + +-- | Find the neighbors for a 'Node'. +neighbors :: (Graph gr) => gr a b -> Node -> [Node] +neighbors = map snd .: lneighbors + +-- | Find the labelled links coming into or going from a 'Context'. +lneighbors :: (Graph gr) => gr a b -> Node -> Adj b +lneighbors = maybe [] lneighbors' .: mcontext + +-- | Find all 'Node's that have a link from the given 'Node'. +suc :: (Graph gr) => gr a b -> Node -> [Node] +suc = map snd .: context4l + +-- | Find all 'Node's that link to to the given 'Node'. +pre :: (Graph gr) => gr a b -> Node -> [Node] +pre = map snd .: context1l + +-- | Find all 'Node's that are linked from the given 'Node' and the label of +-- each link. +lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)] +lsuc = map flip2 .: context4l + +-- | Find all 'Node's that link to the given 'Node' and the label of each link. +lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)] +lpre = map flip2 .: context1l + +-- | Find all outward-bound 'LEdge's for the given 'Node'. +out :: (Graph gr) => gr a b -> Node -> [LEdge b] +out g v = map (\(l,w)->(v,w,l)) (context4l g v) + +-- | Find all inward-bound 'LEdge's for the given 'Node'. +inn :: (Graph gr) => gr a b -> Node -> [LEdge b] +inn g v = map (\(l,w)->(w,v,l)) (context1l g v) + +-- | The outward-bound degree of the 'Node'. +outdeg :: (Graph gr) => gr a b -> Node -> Int +outdeg = length .: context4l + +-- | The inward-bound degree of the 'Node'. +indeg :: (Graph gr) => gr a b -> Node -> Int +indeg = length .: context1l + +-- | The degree of the 'Node'. +deg :: (Graph gr) => gr a b -> Node -> Int +deg = deg' .: context + +-- | The 'Node' in a 'Context'. +node' :: Context a b -> Node +node' (_,v,_,_) = v + +-- | The label in a 'Context'. +lab' :: Context a b -> a +lab' (_,_,l,_) = l + +-- | The 'LNode' from a 'Context'. +labNode' :: Context a b -> LNode a +labNode' (_,v,l,_) = (v,l) + +-- | All 'Node's linked to or from in a 'Context'. +neighbors' :: Context a b -> [Node] +neighbors' (p,_,_,s) = map snd p++map snd s + +-- | All labelled links coming into or going from a 'Context'. +lneighbors' :: Context a b -> Adj b +lneighbors' (p,_,_,s) = p ++ s + +-- | All 'Node's linked to in a 'Context'. +suc' :: Context a b -> [Node] +suc' = map snd . context4l' + +-- | All 'Node's linked from in a 'Context'. +pre' :: Context a b -> [Node] +pre' = map snd . context1l' + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lsuc' :: Context a b -> [(Node,b)] +lsuc' = map flip2 . context4l' + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lpre' :: Context a b -> [(Node,b)] +lpre' = map flip2 . context1l' + +-- | All outward-directed 'LEdge's in a 'Context'. +out' :: Context a b -> [LEdge b] +out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c) + +-- | All inward-directed 'LEdge's in a 'Context'. +inn' :: Context a b -> [LEdge b] +inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c) + +-- | The outward degree of a 'Context'. +outdeg' :: Context a b -> Int +outdeg' = length . context4l' + +-- | The inward degree of a 'Context'. +indeg' :: Context a b -> Int +indeg' = length . context1l' + +-- | The degree of a 'Context'. +deg' :: Context a b -> Int +deg' (p,_,_,s) = length p+length s + +-- | Checks if there is a directed edge between two nodes. +hasEdge :: Graph gr => gr a b -> Edge -> Bool +hasEdge gr (v,w) = w `elem` suc gr v + +-- | Checks if there is an undirected edge between two nodes. +hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool +hasNeighbor gr v w = w `elem` neighbors gr v + +-- | Checks if there is a labelled edge between two nodes. +hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool +hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v + +-- | Checks if there is an undirected labelled edge between two nodes. +hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool +hasNeighborAdj gr v a = a `elem` lneighbors gr v + +---------------------------------------------------------------------- +-- GRAPH EQUALITY +---------------------------------------------------------------------- + +slabNodes :: (Graph gr) => gr a b -> [LNode a] +slabNodes = sortBy (compare `on` fst) . labNodes + +glabEdges :: (Graph gr) => gr a b -> [GroupEdges b] +glabEdges = map (GEs . groupLabels) + . groupBy ((==) `on` toEdge) + . sortBy (compare `on` toEdge) + . labEdges + where + groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les) + +equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool +equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g' +-- This assumes that nodes aren't repeated (which shouldn't happen for +-- sane graph instances). If node IDs are repeated, then the usage of +-- slabNodes cannot guarantee stable ordering. + +-- Newtype wrapper just to test for equality of multiple edges. This +-- is needed because without an Ord constraint on `b' it is not +-- possible to guarantee a stable ordering on edge labels. +newtype GroupEdges b = GEs (LEdge [b]) + deriving (Show, Read) + +instance (Eq b) => Eq (GroupEdges b) where + (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2 + && w1 == w2 + && eqLists bs1 bs2 + +eqLists :: (Eq a) => [a] -> [a] -> Bool +eqLists xs ys = null (xs \\ ys) && null (ys \\ xs) +-- OK to use \\ here as we want each value in xs to cancel a *single* +-- value in ys. + +---------------------------------------------------------------------- +-- UTILITIES +---------------------------------------------------------------------- + +-- auxiliary functions used in the implementation of the +-- derived class members +-- +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +-- f .: g = \x y->f (g x y) +-- f .: g = (f .) . g +-- (.:) f = ((f .) .) +-- (.:) = (.) (.) (.) +(.:) = (.) . (.) + +flip2 :: (a,b) -> (b,a) +flip2 (x,y) = (y,x) + +-- projecting on context elements +-- +context1l :: (Graph gr) => gr a b -> Node -> Adj b +context1l = maybe [] context1l' .: mcontext + +context4l :: (Graph gr) => gr a b -> Node -> Adj b +context4l = maybe [] context4l' .: mcontext + +mcontext :: (Graph gr) => gr a b -> Node -> MContext a b +mcontext = fst .: flip match + +context1l' :: Context a b -> Adj b +context1l' (p,v,_,s) = p++filter ((==v).snd) s + +context4l' :: Context a b -> Adj b +context4l' (p,v,_,s) = s++filter ((==v).snd) p + +---------------------------------------------------------------------- +-- PRETTY PRINTING +---------------------------------------------------------------------- + +-- | Pretty-print the graph. Note that this loses a lot of +-- information, such as edge inverses, etc. +prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String +prettify g = foldr (showsContext . context g) id (nodes g) "" + where + showsContext (_,n,l,s) sg = shows n . (':':) . shows l + . showString "->" . shows s + . ('\n':) . sg + +-- | Pretty-print the graph to stdout. +prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO () +prettyPrint = putStr . prettify + +---------------------------------------------------------------------- +-- Ordered Graph +---------------------------------------------------------------------- + +-- | OrdGr comes equipped with an Ord instance, so that graphs can be +-- used as e.g. Map keys. +newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b } + deriving (Read,Show) + +instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where + g1 == g2 = compare g1 g2 == EQ + +instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where + compare (OrdGr g1) (OrdGr g2) = + (compare `on` sort . labNodes) g1 g2 + `mappend` (compare `on` sort . labEdges) g1 g2 + + +{----------------------------------------------------------------- + +Copyright (c) 1999-2008, Martin Erwig + 2010, Ivan Lazar Miljenovic + 2022, Norman Ramsey +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------} diff --git a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} + +-- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph' +-- using big-endian patricia tree (i.e. "Data.IntMap"). +-- +-- This module provides the following specialised functions to gain +-- more performance, using GHC's RULES pragma: +-- +-- * 'Data.Graph.Inductive.Graph.insNode' +-- +-- * 'Data.Graph.Inductive.Graph.insEdge' +-- +-- * 'Data.Graph.Inductive.Graph.gmap' +-- +-- * 'Data.Graph.Inductive.Graph.nmap' +-- +-- * 'Data.Graph.Inductive.Graph.emap' +-- +-- Code is from Hackage `fgl` package version 5.7.0.3 + + +module GHC.Data.Graph.Inductive.PatriciaTree + ( Gr + , UGr + ) + where + +import GHC.Prelude + +import GHC.Data.Graph.Inductive.Graph + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) + +import qualified Data.IntMap.Strict as IMS + +import GHC.Generics (Generic) + +import Data.Bifunctor + +---------------------------------------------------------------------- +-- GRAPH REPRESENTATION +---------------------------------------------------------------------- + +newtype Gr a b = Gr (GraphRep a b) + deriving (Generic) + +type GraphRep a b = IntMap (Context' a b) +type Context' a b = (IntMap [b], a, IntMap [b]) + +type UGr = Gr () () + +---------------------------------------------------------------------- +-- CLASS INSTANCES +---------------------------------------------------------------------- + +instance (Eq a, Ord b) => Eq (Gr a b) where + (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2 + where + sortAdj (p,n,s) = (fmap sort p,n,fmap sort s) + +instance (Show a, Show b) => Show (Gr a b) where + showsPrec d g = showParen (d > 10) $ + showString "mkGraph " + . shows (labNodes g) + . showString " " + . shows (labEdges g) + +instance (Read a, Read b) => Read (Gr a b) where + readsPrec p = readParen (p > 10) $ \ r -> do + ("mkGraph", s) <- lex r + (ns,t) <- reads s + (es,u) <- reads t + return (mkGraph ns es, u) + +instance Graph Gr where + empty = Gr IM.empty + + isEmpty (Gr g) = IM.null g + + match = matchGr + + mkGraph vs es = insEdges es + . Gr + . IM.fromList + . map (second (\l -> (IM.empty,l,IM.empty))) + $ vs + + labNodes (Gr g) = [ (node, label) + | (node, (_, label, _)) <- IM.toList g ] + + noNodes (Gr g) = IM.size g + + nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph") + $ liftA2 (,) (ix (IM.minViewWithKey g)) + (ix (IM.maxViewWithKey g)) + where + ix = fmap (fst . fst) + + labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g + (next, labels) <- IM.toList s + label <- labels + return (node, next, label) + +instance DynGraph Gr where + (p, v, l, s) & (Gr g) + = let !g1 = IM.insert v (preds, l, succs) g + !(np, preds) = fromAdjCounting p + !(ns, succs) = fromAdjCounting s + !g2 = addSucc g1 v np preds + !g3 = addPred g2 v ns succs + in Gr g3 + + +instance Functor (Gr a) where + fmap = fastEMap + +instance Bifunctor Gr where + bimap = fastNEMap + + first = fastNMap + + second = fastEMap + + +matchGr :: Node -> Gr a b -> Decomp Gr a b +matchGr node (Gr g) + = case IM.lookup node g of + Nothing + -> (Nothing, Gr g) + + Just (p, label, s) + -> let !g1 = IM.delete node g + !p' = IM.delete node p + !s' = IM.delete node s + !g2 = clearPred g1 node s' + !g3 = clearSucc g2 node p' + in (Just (toAdj p', node, label, toAdj s), Gr g3) + +---------------------------------------------------------------------- +-- OVERRIDING FUNCTIONS +---------------------------------------------------------------------- + +{- + +{- RULES + "insNode/Data.Graph.Inductive.PatriciaTree" insNode = fastInsNode + -} +fastInsNode :: LNode a -> Gr a b -> Gr a b +fastInsNode (v, l) (Gr g) = g' `seq` Gr g' + where + g' = IM.insert v (IM.empty, l, IM.empty) g + +-} +{-# RULES + "insEdge/GHC.Data.Graph.Inductive.PatriciaTree" insEdge = fastInsEdge + #-} +fastInsEdge :: LEdge b -> Gr a b -> Gr a b +fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2 + where + g1 = IM.adjust addS' v g + g2 = IM.adjust addP' w g1 + + addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss) + addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss) + +{- + +{- RULES + "gmap/Data.Graph.Inductive.PatriciaTree" gmap = fastGMap + -} +fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d +fastGMap f (Gr g) = Gr (IM.mapWithKey f' g) + where + f' :: Node -> Context' a b -> Context' c d + f' = ((fromContext . f) .) . toContext + +{- RULES + "nmap/Data.Graph.Inductive.PatriciaTree" nmap = fastNMap + -} +-} +fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b +fastNMap f (Gr g) = Gr (IM.map f' g) + where + f' :: Context' a b -> Context' c b + f' (ps, a, ss) = (ps, f a, ss) +{- + +{- RULES + "emap/GHC.Data.Graph.Inductive.PatriciaTree" emap = fastEMap + -} +-} +fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c +fastEMap f (Gr g) = Gr (IM.map f' g) + where + f' :: Context' a b -> Context' a c + f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss) + +{- RULES + "nemap/GHC.Data.Graph.Inductive.PatriciaTree" nemap = fastNEMap + -} + +fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d +fastNEMap fn fe (Gr g) = Gr (IM.map f g) + where + f :: Context' a b -> Context' c d + f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss) + + + +---------------------------------------------------------------------- +-- UTILITIES +---------------------------------------------------------------------- + +toAdj :: IntMap [b] -> Adj b +toAdj = concatMap expand . IM.toList + where + expand (n,ls) = map (flip (,) n) ls + +--fromAdj :: Adj b -> IntMap [b] +--fromAdj = IM.fromListWith addLists . map (second (:[]) . swap) + +data FromListCounting a = FromListCounting !Int !(IntMap a) + deriving (Eq, Show, Read) + +getFromListCounting :: FromListCounting a -> (Int, IntMap a) +getFromListCounting (FromListCounting i m) = (i, m) +{-# INLINE getFromListCounting #-} + +fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty) + where + ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t) +{-# INLINE fromListWithKeyCounting #-} + +fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y) +{-# INLINE fromListWithCounting #-} + +fromAdjCounting :: Adj b -> (Int, IntMap [b]) +fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap) + +-- We use differenceWith to modify a graph more than bulkThreshold times, +-- and repeated insertWith otherwise. +bulkThreshold :: Int +bulkThreshold = 5 + +--toContext :: Node -> Context' a b -> Context a b +--toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss) + +--fromContext :: Context a b -> Context' a b +--fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss) + +-- A version of @++@ where order isn't important, so @xs ++ [x]@ +-- becomes @x:xs@. Used when we have to have a function of type @[a] +-- -> [a] -> [a]@ but one of the lists is just going to be a single +-- element (and it isn't possible to tell which). +addLists :: [a] -> [a] -> [a] +addLists [a] as = a : as +addLists as [a] = a : as +addLists xs ys = xs ++ ys + +addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addSucc g0 v numAdd xs + | numAdd < bulkThreshold = foldlWithKey' go g0 xs + where + go :: GraphRep a b -> Node -> [b] -> GraphRep a b + go g p l = IMS.adjust f p g + where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss + in (ps, l', ss') +addSucc g v _ xs = IMS.differenceWith go g xs + where + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss + in Just (ps, l', ss') + +foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a +foldlWithKey' = + IM.foldlWithKey' + +addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addPred g0 v numAdd xs + | numAdd < bulkThreshold = foldlWithKey' go g0 xs + where + go :: GraphRep a b -> Node -> [b] -> GraphRep a b + go g p l = IMS.adjust f p g + where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps + in (ps', l', ss) +addPred g v _ xs = IMS.differenceWith go g xs + where + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps + in Just (ps', l', ss) + +clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearSucc g v = IMS.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = let !ss' = IM.delete v ss + in Just (ps, l, ss') + +clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearPred g v = IMS.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = let !ps' = IM.delete v ps + in Just (ps', l, ss) + +{----------------------------------------------------------------- + +Copyright (c) 1999-2008, Martin Erwig + 2010, Ivan Lazar Miljenovic + 2022, Norman Ramsey +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------} 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 @@ -27,7 +27,7 @@ import GHC.Cmm import GHC.Cmm.CLabel -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.CmmToAsm ( initNCGConfig ) import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig ) @@ -105,7 +105,7 @@ (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of Just err -> do { logMsg logger - MCDump + MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint" noSrcSpan $ withPprStyle defaultDumpStyle err ; ghcExit logger 1 diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs --- a/compiler/GHC/Driver/Config/Cmm.hs +++ b/compiler/GHC/Driver/Config/Cmm.hs @@ -4,7 +4,7 @@ import GHC.Cmm.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Backend import GHC.Platform diff --git a/compiler/GHC/Driver/Config/Cmm/Parser.hs b/compiler/GHC/Driver/Config/Cmm/Parser.hs --- a/compiler/GHC/Driver/Config/Cmm/Parser.hs +++ b/compiler/GHC/Driver/Config/Cmm/Parser.hs @@ -6,7 +6,7 @@ import GHC.Driver.Config.Parser import GHC.Driver.Config.StgToCmm -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Panic diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs --- a/compiler/GHC/Driver/Config/CmmToAsm.hs +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -5,7 +5,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Platform import GHC.Unit.Types (Module) @@ -66,8 +66,7 @@ , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags - -- Disabled due to https://gitlab.haskell.org/ghc/ghc/-/issues/24507 - , ncgEnableShortcutting = False -- gopt Opt_AsmShortcutting dflags + , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags , ncgComputeUnwinding = debugLevel dflags > 0 , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags) -- Disable when -finfo-table-map is on (#20428) diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs b/compiler/GHC/Driver/Config/CmmToLlvm.hs --- a/compiler/GHC/Driver/Config/CmmToLlvm.hs +++ b/compiler/GHC/Driver/Config/CmmToLlvm.hs @@ -4,7 +4,7 @@ where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.LlvmConfigCache import GHC.Platform import GHC.CmmToLlvm.Config diff --git a/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs b/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs --- a/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs +++ b/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs @@ -5,7 +5,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config.Core.Lint import GHC.Core diff --git a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs --- a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs @@ -4,7 +4,7 @@ import GHC.Prelude () -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.Opt.Arity diff --git a/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs b/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs --- a/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs @@ -2,7 +2,7 @@ ( initLiberateCaseOpts ) where -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) ) diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs --- a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -17,7 +17,7 @@ import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig ) import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) -import GHC.Driver.Session ( DynFlags(..), GeneralFlag(..), gopt ) +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt ) import GHC.Runtime.Context ( InteractiveContext(..) ) @@ -80,7 +80,6 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") { -- Don't do case-of-case transformations. -- This makes full laziness work better - -- See Note [Case-of-case and full laziness] sm_case_case = False } @@ -90,37 +89,3 @@ (True, True) -> FloatEnabled (True, False)-> FloatNestedOnly (False, _) -> FloatDisabled - - -{- Note [Case-of-case and full laziness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case-of-case can hide opportunities for let-floating (full laziness). -For example - rec { f = \y. case (expensive x) of (a,b) -> blah } -We might hope to float the (expensive x) out of the \y-loop. -But if we inline `expensive` we might get - \y. case (case x of I# x' -> body) of (a,b) -> blah -Now if we do case-of-case we get - \y. case x if I# x2 -> - case body of (a,b) -> blah - -Sadly, at this point `body` mentions `x2`, so we can't float it out of the -\y-loop. - -Solution: don't do case-of-case in the "gentle" simplification phase that -precedes the first float-out transformation. Implementation: - - * `sm_case_case` field in SimplMode - - * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case - in GHC.Core.Opt.Simplify.Iteration.rebuildCall. - -Wrinkles - -* This applies equally to the case-of-runRW# transformation: - case (runRW# (\s. body)) of (a,b) -> blah - ---> - runRW# (\s. case body of (a,b) -> blah) - Again, don't do this when `sm_case_case` is off. See #25055 for - a motivating example. --} diff --git a/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs b/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs --- a/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs @@ -5,7 +5,7 @@ import GHC.Prelude () import GHC.Driver.Config (initSimpleOpts) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap diff --git a/compiler/GHC/Driver/Config/Core/Rules.hs b/compiler/GHC/Driver/Config/Core/Rules.hs --- a/compiler/GHC/Driver/Config/Core/Rules.hs +++ b/compiler/GHC/Driver/Config/Core/Rules.hs @@ -5,7 +5,7 @@ import GHC.Prelude import GHC.Driver.Flags -import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) +import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform, homeUnitId_ ) import GHC.Core.Rules.Config diff --git a/compiler/GHC/Driver/Config/CoreToStg.hs b/compiler/GHC/Driver/Config/CoreToStg.hs --- a/compiler/GHC/Driver/Config/CoreToStg.hs +++ b/compiler/GHC/Driver/Config/CoreToStg.hs @@ -1,7 +1,7 @@ module GHC.Driver.Config.CoreToStg where import GHC.Driver.Config.Stg.Debug -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.CoreToStg diff --git a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs --- a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs +++ b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs @@ -25,8 +25,6 @@ return $ CorePrepConfig { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env , cp_convertNumLit = convertNumLit - , cp_specEval = gopt Opt_SpecEval $ hsc_dflags hsc_env - , cp_specEvalDFun = gopt Opt_SpecEvalDictFun $ hsc_dflags hsc_env } initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs --- a/compiler/GHC/Driver/Config/Finder.hs +++ b/compiler/GHC/Driver/Config/Finder.hs @@ -5,7 +5,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Unit.Finder.Types import GHC.Data.FastString diff --git a/compiler/GHC/Driver/Config/HsToCore.hs b/compiler/GHC/Driver/Config/HsToCore.hs --- a/compiler/GHC/Driver/Config/HsToCore.hs +++ b/compiler/GHC/Driver/Config/HsToCore.hs @@ -4,7 +4,7 @@ where import GHC.Types.Id.Make -import GHC.Driver.Session +import GHC.Driver.DynFlags import qualified GHC.LanguageExtensions as LangExt initBangOpts :: DynFlags -> BangOpts diff --git a/compiler/GHC/Driver/Config/HsToCore/Ticks.hs b/compiler/GHC/Driver/Config/HsToCore/Ticks.hs --- a/compiler/GHC/Driver/Config/HsToCore/Ticks.hs +++ b/compiler/GHC/Driver/Config/HsToCore/Ticks.hs @@ -1,5 +1,6 @@ module GHC.Driver.Config.HsToCore.Ticks ( initTicksConfig + , breakpointsAllowed ) where @@ -18,9 +19,14 @@ , ticks_countEntries = gopt Opt_ProfCountEntries dflags } +breakpointsAllowed :: DynFlags -> Bool +breakpointsAllowed dflags = + gopt Opt_InsertBreakpoints dflags && + backendSupportsBreakpoints (backend dflags) + coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = catMaybes - [ ifA Breakpoints $ backendWantsBreakpointTicks $ backend dflags + [ ifA Breakpoints $ breakpointsAllowed dflags , ifA HpcTicks $ gopt Opt_Hpc dflags , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto , ifA SourceNotes $ needSourceNotes dflags diff --git a/compiler/GHC/Driver/Config/Linker.hs b/compiler/GHC/Driver/Config/Linker.hs --- a/compiler/GHC/Driver/Config/Linker.hs +++ b/compiler/GHC/Driver/Config/Linker.hs @@ -4,7 +4,7 @@ import GHC.Linker.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags initFrameworkOpts :: DynFlags -> FrameworkOpts initFrameworkOpts dflags = FrameworkOpts diff --git a/compiler/GHC/Driver/Config/Stg/Debug.hs b/compiler/GHC/Driver/Config/Stg/Debug.hs --- a/compiler/GHC/Driver/Config/Stg/Debug.hs +++ b/compiler/GHC/Driver/Config/Stg/Debug.hs @@ -4,7 +4,7 @@ import GHC.Stg.Debug -import GHC.Driver.Session +import GHC.Driver.DynFlags -- | Initialize STG pretty-printing options from DynFlags initStgDebugOpts :: DynFlags -> StgDebugOpts diff --git a/compiler/GHC/Driver/Config/Stg/Lift.hs b/compiler/GHC/Driver/Config/Stg/Lift.hs --- a/compiler/GHC/Driver/Config/Stg/Lift.hs +++ b/compiler/GHC/Driver/Config/Stg/Lift.hs @@ -4,7 +4,7 @@ import GHC.Stg.Lift.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags initStgLiftConfig :: DynFlags -> StgLiftConfig initStgLiftConfig dflags = StgLiftConfig diff --git a/compiler/GHC/Driver/Config/Stg/Pipeline.hs b/compiler/GHC/Driver/Config/Stg/Pipeline.hs --- a/compiler/GHC/Driver/Config/Stg/Pipeline.hs +++ b/compiler/GHC/Driver/Config/Stg/Pipeline.hs @@ -11,7 +11,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Stg.Lift import GHC.Driver.Config.Stg.Ppr -import GHC.Driver.Session +import GHC.Driver.DynFlags -- | Initialize STG pretty-printing options from DynFlags initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + module GHC.Driver.Config.StgToCmm ( initStgToCmmConfig ) where @@ -6,6 +9,7 @@ import GHC.StgToCmm.Config +import GHC.Cmm.MachOp ( FMASign(..)) import GHC.Driver.Backend import GHC.Driver.Session import GHC.Platform @@ -38,8 +42,6 @@ , stgToCmmSCCProfiling = sccProfilingEnabled dflags , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags - , stgToCmmInfoTableMapWithFallback = gopt Opt_InfoTableMapWithFallback dflags - , stgToCmmInfoTableMapWithStack = gopt Opt_InfoTableMapWithStack dflags , stgToCmmOmitYields = gopt Opt_OmitYields dflags , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags , stgToCmmPIC = gopt Opt_PIC dflags @@ -52,6 +54,24 @@ , stgToCmmAllowQuotRemInstr = ncg && (x86ish || ppc) , stgToCmmAllowQuotRem2 = (ncg && (x86ish || ppc)) || llvm , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowFMAInstr = + if + | not (isFmaEnabled dflags) + || not (ncg || llvm) + -- If we're not using the native code generator or LLVM, + -- fall back to the generic implementation. + || platformArch platform == ArchWasm32 + -- WASM doesn't support native FMA instructions (at the time of writing). + -> const False + + -- FNMSub and FNMAdd have different semantics on PowerPC, + -- so we avoid using them. + | ppc + -> \ case { FMAdd -> True; FMSub -> True; _ -> False } + + | otherwise + -> const True + , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm -- SIMD flags , stgToCmmVecInstrsErr = vec_err diff --git a/compiler/GHC/Driver/Config/StgToJS.hs b/compiler/GHC/Driver/Config/StgToJS.hs --- a/compiler/GHC/Driver/Config/StgToJS.hs +++ b/compiler/GHC/Driver/Config/StgToJS.hs @@ -5,7 +5,7 @@ import GHC.StgToJS.Types -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Platform.Ways import GHC.Utils.Outputable @@ -20,6 +20,7 @@ , csInlineLoadRegs = False , csInlineEnter = False , csInlineAlloc = False + , csPrettyRender = gopt Opt_DisableJsMinifier dflags , csTraceRts = False , csAssertRts = False , csBoundsCheck = gopt Opt_DoBoundsChecking dflags diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs --- a/compiler/GHC/Driver/Config/Tidy.hs +++ b/compiler/GHC/Driver/Config/Tidy.hs @@ -12,16 +12,13 @@ import GHC.Iface.Tidy import GHC.Iface.Tidy.StaticPtrTable -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Backend import GHC.Core.Make (getMkStringIds) -import GHC.Data.Maybe -import GHC.Utils.Panic -import GHC.Utils.Outputable import GHC.Builtin.Names -import GHC.Tc.Utils.Env (lookupGlobal_maybe) +import GHC.Tc.Utils.Env (lookupGlobal) import GHC.Types.TyThing import GHC.Platform.Ways @@ -49,13 +46,9 @@ initStaticPtrOpts hsc_env = do let dflags = hsc_dflags hsc_env - let lookupM n = lookupGlobal_maybe hsc_env n >>= \case - Succeeded r -> pure r - Failed err -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n)) - - mk_string <- getMkStringIds (fmap tyThingId . lookupM) - static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName - static_ptr_datacon <- tyThingDataCon <$> lookupM staticPtrDataConName + mk_string <- getMkStringIds (fmap tyThingId . lookupGlobal hsc_env ) + static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName + static_ptr_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrDataConName pure $ StaticPtrOpts { opt_platform = targetPlatform dflags diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs --- a/compiler/GHC/Driver/GenerateCgIPEStub.hs +++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs @@ -1,40 +1,37 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} -module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where +module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Semigroup ((<>)) +import Data.Maybe (mapMaybe, listToMaybe) import GHC.Cmm -import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel) -import GHC.Cmm.Dataflow (O) +import GHC.Cmm.CLabel (CLabel) +import GHC.Cmm.Dataflow (Block, C, O) import GHC.Cmm.Dataflow.Block (blockSplit, blockToList) -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Collections (mapToList) import GHC.Cmm.Dataflow.Label (Label) import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline) +import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv) -import GHC.Driver.Flags (GeneralFlag (..), DumpFlag(Opt_D_ipe_stats)) -import GHC.Driver.Session (gopt, targetPlatform) +import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) +import GHC.Driver.DynFlags (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm import GHC.Driver.Config.Cmm import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) -import GHC.Settings (platformTablesNextToCode) +import GHC.Settings (Platform, platformTablesNextToCode) import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) -import GHC.StgToCmm.Utils import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.Tickish (GenTickish (SourceNote)) -import GHC.Unit.Types (Module, moduleName) -import GHC.Unit.Module (moduleNameString) -import qualified GHC.Utils.Logger as Logger -import GHC.Utils.Outputable (ppr) +import GHC.Unit.Types (Module) +import GHC.Utils.Misc {- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] @@ -55,16 +52,10 @@ This leads to the question: How to figure out the source location of a return frame? -The algorithm for determining source locations for stack info tables is implemented in -`lookupEstimatedTicks` as two passes over every 'CmmGroupSRTs'. The first pass generates estimated -source locations for any labels potentially corresponding to stack info tables in the Cmm code. The -second pass walks over the Cmm decls and creates an entry in the IPE map for every info table, -looking up source locations for stack info tables in the map generated during the first pass. - -The rest of this note will document exactly how the first pass generates the map from labels to -estimated source positions. The algorithms are different depending on whether tables-next-to-code -is on or off. Both algorithms have in common that we are looking for a `CmmNode.CmmTick` -(containing a `SourceNote`) that is near what we estimate to be the label of a return stack frame. +While the lookup algorithms when tables-next-to-code is on/off differ in details, they have in +common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest +(before) the usage of the return frame's label. (Which label and label type is used differs between +these two use cases.) With tables-next-to-code ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -116,15 +107,15 @@ Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit (`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block. -So, given a `CmmGraph`: - - Look at the end of every block: If it is a `CmmNode.CmmCall` returning to some label, lookup - the nearest `CmmNode.CmmTick` by traversing the middle part of the block backwards (from end to - beginning). - - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and map the label we - found to it's payload as an `IpeSourceLocation`. (There are other `Tickish` constructors like - `ProfNote` or `HpcTick`, these are ignored.) - -See `labelsToSourcesWithTNTC` for the implementation of this algorithm. +So, given a stack represented info table (likely representing a return frame, but this isn't completely +sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`: + - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the + label of the return frame. + - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block + backwards (from end to beginning). + - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as + `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are + ignored.) Without tables-next-to-code ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -179,27 +170,16 @@ Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info` (`label: block_c18M_info` is actually a `CLabel`). -Given a `CmmGraph`: - - Check every `CmmBlock` from top (first) to bottom (last). - - If a `CmmTick` holding a `SourceNote` is found, remember the source location in the tick. - - If an assignment of the form `... = block_c18M_info;` (a `CmmStore` whose RHS is a - `CmmLit (CmmLabel l)`) is found, map that label to the most recently visited source note's - location. - -See `labelsToSourcesSansTNTC` for the implementation of this algorithm. +The find the tick: + - Every `Block` is checked from top (first) to bottom (last) node for an assignment like + `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored. + - If such an assignment is found the search is over, because the payload (content of + `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always + remembered in a `Maybe`. -} -generateCgIPEStub - :: HscEnv - -> Module - -> InfoTableProvMap - -> ( NonCaffySet - , ModuleLFInfos - , Map CmmInfoTable (Maybe IpeSourceLocation) - , IPEStats - ) - -> Stream IO CmmGroupSRTs CmmCgInfos -generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = do +generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos +generateCgIPEStub hsc_env this_mod denv s = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags logger = hsc_logger hsc_env @@ -207,169 +187,82 @@ cmm_cfg = initCmmConfig dflags cgState <- liftIO initC + -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty. + let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing + (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s + -- Yield Cmm for Info Table Provenance Entries (IPEs) - let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes} - ((mIpeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv') + let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)} + ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv') (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs - ipeStub <- - case mIpeStub of - Just (stats, stub) -> do - -- Print ipe stats if requested - liftIO $ - Logger.putDumpFileMaybe logger - Opt_D_ipe_stats - ("IPE Stats for module " ++ (moduleNameString $ moduleName this_mod)) - Logger.FormatText - (ppr stats) - return stub - Nothing -> return mempty - return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} - --- | Given: --- * an initial mapping from info tables to possible source locations, --- * initial 'IPEStats', --- * a 'CmmGroupSRTs', --- --- map every info table listed in the 'CmmProc's of the group to their possible --- source locations and update 'IPEStats' for skipped stack info tables (in case --- both -finfo-table-map and -fno-info-table-map-with-stack were given). See: --- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] --- --- Note: While it would be cleaner if we could keep the recursion and --- accumulation internal to this function, this cannot be done without --- separately traversing stream of 'CmmGroupSRTs' in 'GHC.Driver.Main'. The --- initial implementation of this logic did such a thing, and code generation --- performance suffered considerably as a result (see #23103). -lookupEstimatedTicks - :: HscEnv - -> Map CmmInfoTable (Maybe IpeSourceLocation) - -> IPEStats - -> CmmGroupSRTs - -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) -lookupEstimatedTicks hsc_env ipes stats cmm_group_srts = - -- Pass 2: Create an entry in the IPE map for every info table listed in - -- this CmmGroupSRTs. If the info table is a stack info table and - -- -finfo-table-map-with-stack is enabled, look up its estimated source - -- location in the map generate during Pass 1. If the info table is a stack - -- info table and -finfo-table-map-with-stack is not enabled, skip the table - -- and note it as skipped in the IPE stats. If the info table is not a stack - -- info table, insert into the IPE map with no source location information - -- (for now; see `convertInfoProvMap` in GHC.StgToCmm.Utils to see how source - -- locations for these tables get filled in) - pure $ foldl' collectInfoTables (ipes, stats) cmm_group_srts where - dflags = hsc_dflags hsc_env - platform = targetPlatform dflags + collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs) + collect platform acc cmmGroupSRTs = do + let labelsToInfoTables = collectInfoTables cmmGroupSRTs + labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables + return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs) - -- Pass 1: Map every label meeting the conditions described in Note - -- [Stacktraces from Info Table Provenance Entries (IPE based stack - -- unwinding)] to the estimated source location (also as described in the - -- aformentioned note) - -- - -- Note: It's important that this remains a thunk so we do not compute this - -- map if -fno-info-table-with-stack is given - labelsToSources :: Map CLabel IpeSourceLocation - labelsToSources = - if platformTablesNextToCode platform then - foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts - else - foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts + collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs) + collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs) - collectInfoTables - :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) - -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph - -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) - collectInfoTables (!acc, !stats) (CmmProc h _ _ _) = - mapFoldlWithKey go (acc, stats) (info_tbls h) - where - go :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) - -> Label - -> CmmInfoTable - -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) - go (!acc, !stats) lbl' tbl = - let - lbl = - if platformTablesNextToCode platform then - -- TNTC case, the mapped CLabel will be the result of - -- mkAsmTempLabel on the info table label - mkAsmTempLabel lbl' - else - -- Non-TNTC case, the mapped CLabel will be the CLabel of the - -- info table itself - cit_lbl tbl - in - if (isStackRep . cit_rep) tbl then - if gopt Opt_InfoTableMapWithStack dflags then - -- This is a stack info table and we DO want to put it in the - -- info table map - (Map.insert tbl (Map.lookup lbl labelsToSources) acc, stats) - else - -- This is a stack info table but we DO NOT want to put it in - -- the info table map (-fno-info-table-map-with-stack was - -- given), track it as skipped - (acc, stats <> skippedIpeStats) - else - -- This is not a stack info table, so put it in the map with no - -- source location (for now) - (Map.insert tbl Nothing acc, stats) - collectInfoTables (!acc, !stats) _ = (acc, stats) + collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)] + collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup --- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] -labelsToSourcesWithTNTC - :: Map CLabel IpeSourceLocation - -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph - -> Map CLabel IpeSourceLocation -labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) = - foldl' go acc (toBlockList cmm_graph) - where - go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation - go acc block = - case (,) <$> returnFrameLabel <*> lastTickInBlock of - Just (clabel, src_loc) -> Map.insert clabel src_loc acc - Nothing -> acc + extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)] + extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h) + extractInfoTables _ = Nothing + + lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation + lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do + -- All return frame info tables are stack represented, though not all stack represented info + -- tables have to be return frames. + if (isStackRep . cit_rep) infoTable + then do + let findFun = + if platformTablesNextToCode platform + then findCmmTickishWithTNTC infoTableLabel + else findCmmTickishSansTNTC (cit_lbl infoTable) + blocks = concatMap toBlockList (graphs cmmGroup) + firstJusts $ map findFun blocks + else Nothing + graphs :: CmmGroupSRTs -> [CmmGraph] + graphs = foldl' go [] where - (_, middleBlock, endBlock) = blockSplit block + go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph] + go acc (CmmProc _ _ _ g) = g : acc + go acc _ = acc - returnFrameLabel :: Maybe CLabel - returnFrameLabel = - case endBlock of - (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l - _ -> Nothing + findCmmTickishWithTNTC :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation + findCmmTickishWithTNTC label block = do + let (_, middleBlock, endBlock) = blockSplit block - lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock) + isCallWithReturnFrameLabel endBlock label + lastTickInBlock middleBlock + where + isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe () + isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just () + isCallWithReturnFrameLabel _ _ = Nothing - maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation - maybeTick _ s@(Just _) = s - maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name) - maybeTick _ _ = Nothing -labelsToSourcesWithTNTC acc _ = acc + lastTickInBlock block = + listToMaybe $ + mapMaybe maybeTick $ (reverse . blockToList) block --- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] -labelsToSourcesSansTNTC - :: Map CLabel IpeSourceLocation - -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph - -> Map CLabel IpeSourceLocation -labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) = - foldl' go acc (toBlockList cmm_graph) - where - go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation - go acc block = fst $ foldl' collectLabels (acc, Nothing) (blockToList middleBlock) - where - (_, middleBlock, _) = blockSplit block + maybeTick :: CmmNode O O -> Maybe IpeSourceLocation + maybeTick (CmmTick (SourceNote span name)) = Just (span, name) + maybeTick _ = Nothing - collectLabels - :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation) - -> CmmNode O O - -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation) - collectLabels (!acc, lastTick) b = - case (b, lastTick) of - (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) -> - (Map.insert l src_loc acc, Nothing) - (CmmTick (SourceNote span name), _) -> - (acc, Just (span, name)) - _ -> (acc, lastTick) -labelsToSourcesSansTNTC acc _ = acc + findCmmTickishSansTNTC :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation + findCmmTickishSansTNTC cLabel block = do + let (_, middleBlock, _) = blockSplit block + find cLabel (blockToList middleBlock) Nothing + where + find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation + find label (b : blocks) lastTick = case b of + (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick + (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name) + _ -> find label blocks lastTick + find _ [] _ = Nothing 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 @@ -137,16 +137,18 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks -import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) +import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) import GHC.Runtime.Context -import GHC.Runtime.Interpreter ( addSptEntry ) +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.JS import GHC.Runtime.Loader ( initializePlugins ) -import GHCi.RemoteTypes ( ForeignHValue ) +import GHCi.RemoteTypes import GHC.ByteCode.Types import GHC.Linker.Loader import GHC.Linker.Types +import GHC.Linker.Deps import GHC.Hs import GHC.Hs.Dump @@ -156,6 +158,9 @@ import GHC.StgToByteCode ( byteCodeGen ) import GHC.StgToJS ( stgToJS ) +import GHC.StgToJS.Ids +import GHC.StgToJS.Types +import GHC.JS.Syntax import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) @@ -172,7 +177,6 @@ import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) -import GHC.Core.Multiplicity import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike import GHC.Core.Opt.Pipeline @@ -194,17 +198,16 @@ import GHC.Tc.Module import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) +import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax import GHC.Stg.Pipeline ( stg2stg, StgCgInfos ) import GHC.Builtin.Utils import GHC.Builtin.Names -import GHC.Builtin.Uniques ( mkPseudoUniqueE ) import qualified GHC.StgToCmm as StgToCmm ( codeGen ) -import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) +import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..)) import GHC.Cmm import GHC.Cmm.Info.Build @@ -230,7 +233,9 @@ import GHC.Types.SourceError import GHC.Types.SafeHaskell import GHC.Types.ForeignStubs -import GHC.Types.Var.Env ( emptyTidyEnv ) +import GHC.Types.Name.Env ( mkNameEnv ) +import GHC.Types.Var.Env ( mkEmptyTidyEnv ) +import GHC.Types.Var.Set import GHC.Types.Error import GHC.Types.Fixity.Env import GHC.Types.CostCentre @@ -241,8 +246,11 @@ import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr +import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo +import GHC.Types.Unique.Supply (uniqFromMask) +import GHC.Types.Unique.Set import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic @@ -253,6 +261,8 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs +import qualified GHC.LanguageExtensions as LangExt + import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.StringBuffer @@ -271,11 +281,11 @@ import Data.IORef import System.FilePath as FilePath import System.Directory -import qualified Data.Map as M -import Data.Map (Map) import qualified Data.Set as S import Data.Set (Set) +import Data.Functor ((<&>)) import Control.DeepSeq (force) +import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty ((:|))) import GHC.Unit.Module.WholeCoreBindings import GHC.Types.TypeEnv @@ -286,9 +296,8 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) import GHC.Stg.InferTags.TagSig (seqTagSig) -import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM -import GHC.Cmm.Config (CmmConfig) +import GHC.Types.Unique.DFM {- ********************************************************************** @@ -864,6 +873,15 @@ , IsBoot <- isBootSummary mod_summary -> do msg UpToDate return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + + -- Always recompile with the JS backend when TH is enabled until + -- #23013 is fixed. + | ArchJavaScript <- platformArch (targetPlatform lcl_dflags) + , xopt LangExt.TemplateHaskell lcl_dflags + -> do + msg $ needsRecompileBecause THWithJS + return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface + | otherwise -> do -- Do need linkable -- 1. Just check whether we have bytecode/object linkables and then @@ -1685,7 +1703,7 @@ (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ - UnknownDiagnostic $ + mkSimpleUnknownDiagnostic $ mkPlainDiagnostic reason noHints $ whyUnsafe' dflags) @@ -1710,9 +1728,9 @@ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer - badFlag df (str,loc,on,_) + badFlag df (ext,loc,on,_) | on df = [mkLocMessage MCOutput (loc df) $ - text str <+> text "is not allowed in Safe Haskell"] + text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts @@ -1843,7 +1861,7 @@ this_mod location late_cc_binds data_tycons ----------------- Convert to STG ------------------ - (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) + (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) <- {-# SCC "CoreToStg" #-} withTiming logger (text "CoreToStg"<+>brackets (ppr this_mod)) @@ -1853,8 +1871,10 @@ c `seqList` d `seqList` (seqEltsUFM (seqTagSig) tag_env)) - (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds) + (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod location prepd_binds) + let (stg_binds,_stg_deps) = unzip stg_binds_with_deps + let cost_centre_info = (late_local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags @@ -1873,7 +1893,19 @@ JSCodeOutput -> do let js_config = initStgToJSConfig dflags - cmm_cg_infos = Nothing + + -- The JavaScript backend does not create CmmCgInfos like the Cmm backend, + -- but it is needed for writing the interface file. Here we compute a very + -- conservative but correct value. + lf_infos (StgTopLifted (StgNonRec b _)) = [(idName b, LFUnknown True)] + lf_infos (StgTopLifted (StgRec bs)) = map (\(b,_) -> (idName b, LFUnknown True)) bs + lf_infos (StgTopStringLit b _) = [(idName b, LFUnlifted)] + + cmm_cg_infos = CmmCgInfos + { cgNonCafs = mempty + , cgLFInfos = mkNameEnv (concatMap lf_infos stg_binds) + , cgIPEStub = mempty + } stub_c_exists = Nothing foreign_fps = [] @@ -1882,7 +1914,7 @@ -- do the unfortunately effectual business stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename - return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, cmm_cg_infos) + return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos) _ -> do @@ -1961,9 +1993,12 @@ -- The stg cg info only provides a runtime benfit, but is not requires so we just -- omit it here - (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos) + (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos) <- {-# SCC "CoreToStg" #-} - myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds + myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod location prepd_binds + + let (stg_binds,_stg_deps) = unzip stg_binds_with_deps + ----------------- Generate byte code ------------------ comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff ----- @@ -2122,85 +2157,41 @@ cmm_config = initCmmConfig dflags - pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos + pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) pipeline_stream = do - ((mod_srt_info, ipes, ipe_stats), lf_infos) <- + (non_cafs, lf_infos) <- {-# SCC "cmmPipeline" #-} - Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1 - let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info) - generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats) - - pipeline_action - :: Logger - -> CmmConfig - -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) - -> CmmGroup - -> IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs) - pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do - (mod_srt_info', cmm_srts) <- cmmPipeline logger cmm_config mod_srt_info cmm_group - - -- If -finfo-table-map is enabled, we precompute a map from info - -- tables to source locations. See Note [Mapping Info Tables to Source - -- Positions] in GHC.Stg.Debug. - (ipes', stats') <- - if (gopt Opt_InfoTableMap dflags) then - lookupEstimatedTicks hsc_env ipes stats cmm_srts - else - return (ipes, stats) + Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1 + <&> first (srtMapNonCAFs . moduleSRTMap) - return ((mod_srt_info', ipes', stats'), cmm_srts) + return (non_cafs, lf_infos) dump2 a = do unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a - return $ Stream.mapM dump2 pipeline_stream - -myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext - -> Bool - -> Module -> ModLocation -> CoreExpr - -> IO ( Id - , [CgStgTopBinding] - , InfoTableProvMap - , CollectedCCs - , StgCgInfos ) -myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do - {- Create a temporary binding (just because myCoreToStg needs a - binding for the stg2stg step) -} - let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") - (mkPseudoUniqueE 0) - ManyTy - (exprType prepd_expr) - (stg_binds, prov_map, collected_ccs, stg_cg_infos) <- - myCoreToStg logger - dflags - ictxt - for_bytecode - this_mod - ml - [NonRec bco_tmp_id prepd_expr] - return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos) + return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream -myCoreToStg :: Logger -> DynFlags -> InteractiveContext +myCoreToStg :: Logger -> DynFlags -> [Var] -> Bool -> Module -> ModLocation -> CoreProgram - -> IO ( [CgStgTopBinding] -- output program + -> IO ( [(CgStgTopBinding,IdSet)] -- output program and its dependencies , InfoTableProvMap , CollectedCCs -- CAF cost centre info (declared and used) , StgCgInfos ) -myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do +myCoreToStg logger dflags ic_inscope for_bytecode this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds (stg_binds_with_fvs,stg_cg_info) <- {-# SCC "Stg2Stg" #-} - stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode) + stg2stg logger ic_inscope (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG - (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs) + (pprGenStgTopBindings (initStgPprOpts dflags) (fmap fst stg_binds_with_fvs)) return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info) @@ -2353,16 +2344,18 @@ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) this_mod iNTERACTIVELoc core_binds data_tycons - (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info) + (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info) <- {-# SCC "CoreToStg" #-} liftIO $ myCoreToStg (hsc_logger hsc_env) (hsc_dflags hsc_env) - (hsc_IC hsc_env) + (interactiveInScope (hsc_IC hsc_env)) True this_mod iNTERACTIVELoc prepd_binds + let (stg_binds,_stg_deps) = unzip stg_binds_with_deps + {- Generate byte code -} cbc <- liftIO $ byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks @@ -2433,7 +2426,8 @@ _ -> liftIO $ throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ GhcPsMessage $ PsUnknownMessage $ - UnknownDiagnostic $ mkPlainError noHints $ + mkSimpleUnknownDiagnostic $ + mkPlainError noHints $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2464,7 +2458,9 @@ Just (L _ (BodyStmt _ expr _ _)) -> return expr _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ + GhcPsMessage $ PsUnknownMessage + $ mkSimpleUnknownDiagnostic + $ mkPlainError noHints $ text "not an expression:" <+> quotes (text expr) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) @@ -2562,56 +2558,181 @@ Just h -> h hsc_env loc expr hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) -hscCompileCoreExpr' hsc_env srcspan ds_expr - = do { {- Simplify it -} - -- Question: should we call SimpleOpt.simpleOptExpr here instead? - -- It is, well, simpler, and does less inlining etc. - let dflags = hsc_dflags hsc_env - ; let logger = hsc_logger hsc_env - ; let ic = hsc_IC hsc_env - ; let unit_env = hsc_unit_env hsc_env - ; let simplify_expr_opts = initSimplifyExprOpts dflags ic - ; simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr +hscCompileCoreExpr' hsc_env srcspan ds_expr = do + {- Simplify it -} + -- Question: should we call SimpleOpt.simpleOptExpr here instead? + -- It is, well, simpler, and does less inlining etc. + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let ic = hsc_IC hsc_env + let unit_env = hsc_unit_env hsc_env + let simplify_expr_opts = initSimplifyExprOpts dflags ic - {- Tidy it (temporary, until coreSat does cloning) -} - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr - {- Prepare for codegen -} - ; cp_cfg <- initCorePrepConfig hsc_env - ; prepd_expr <- corePrepExpr - logger cp_cfg - tidy_expr + -- Create a unique temporary binding + -- + -- The id has to be exported for the JS backend. This isn't required for the + -- byte-code interpreter but it does no harm to always do it. + u <- uniqFromMask 'I' + let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel")) + let binding_id = mkExportedVanillaId binding_name (exprType simpl_expr) - {- Lint if necessary -} - ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr - ; let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, - ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", - ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", - ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file", - ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file", - ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } + {- Tidy it (temporary, until coreSat does cloning) -} + let tidy_occ_env = initTidyOccEnv [occName binding_id] + let tidy_env = mkEmptyTidyEnv tidy_occ_env + let tidy_expr = tidyExpr tidy_env simpl_expr - ; let ictxt = hsc_IC hsc_env - ; (binding_id, stg_expr, _, _, _stg_cg_info) <- - myCoreToStgExpr logger - dflags - ictxt - True - (icInteractiveModule ictxt) - iNTERACTIVELoc - prepd_expr + {- Prepare for codegen -} + cp_cfg <- initCorePrepConfig hsc_env + prepd_expr <- corePrepExpr + logger cp_cfg + tidy_expr - {- Convert to BCOs -} - ; bcos <- byteCodeGen hsc_env - (icInteractiveModule ictxt) - stg_expr - [] Nothing + {- Lint if necessary -} + lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr + let this_loc = ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", + ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", + ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file", + ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file", + ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } - {- load it -} - ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos - {- Get the HValue for the root -} - ; return (expectJust "hscCompileCoreExpr'" - $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) } + -- Ensure module uniqueness by giving it a name like "GhciNNNN". + -- This uniqueness is needed by the JS linker. Without it we break the 1-1 + -- relationship between modules and object files, i.e. we get different object + -- files for the same module and the JS linker doesn't support this. + -- + -- Note that we can't use icInteractiveModule because the ic_mod_index value + -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't + -- guaranteed. + -- + -- We reuse the unique we obtained for the binding, but any unique would do. + let this_mod = mkInteractiveModule (show u) + let for_bytecode = True + + (stg_binds_with_deps, _prov_map, _collected_ccs, _stg_cg_infos) <- + myCoreToStg logger + dflags + (interactiveInScope (hsc_IC hsc_env)) + for_bytecode + this_mod + this_loc + [NonRec binding_id prepd_expr] + + let (stg_binds, _stg_deps) = unzip stg_binds_with_deps + + let interp = hscInterp hsc_env + + case interp of + -- always generate JS code for the JS interpreter (no bytecode!) + Interp (ExternalInterp (ExtJS i)) _ -> + jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id + + _ -> do + {- Convert to BCOs -} + bcos <- byteCodeGen hsc_env + this_mod + stg_binds + [] Nothing + + {- load it -} + (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan bcos + {- Get the HValue for the root -} + return (expectJust "hscCompileCoreExpr'" + $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) + + + +-- | Generate JS code for the given bindings and return the HValue for the given id +jsCodeGen + :: HscEnv + -> SrcSpan + -> JSInterp + -> Module + -> [(CgStgTopBinding,IdSet)] + -> Id + -> IO (ForeignHValue, [Linkable], PkgsLoaded) +jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + dflags = hsc_dflags hsc_env + interp = hscInterp hsc_env + tmp_dir = tmpDir dflags + unit_env = hsc_unit_env hsc_env + js_config = initStgToJSConfig dflags + + -- We need to load all the dependencies first. + -- + -- We get all the imported names from the Stg bindings and load their modules. + -- + -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker) + let + (stg_binds, stg_deps) = unzip stg_binds_with_deps + imported_ids = nonDetEltsUniqSet (unionVarSets stg_deps) + imported_names = map idName imported_ids + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- imported_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + -- Initialise the linker (if it's not been done already) + initLoaderState interp hsc_env + + -- Take lock for the actual work. + (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do + let link_opts = initLinkDepsOpts hsc_env + + -- Find what packages and linkables are required + deps <- getLinkDeps link_opts interp pls srcspan needed_mods + -- We update the LinkerState even if the JS interpreter maintains its linker + -- state independently to load new objects here. + let (objs, _bcos) = partition isObjectLinkable + (concatMap partitionLinkable (ldNeededLinkables deps)) + + let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs + + -- FIXME: we should make the JS linker load new_objs here, instead of + -- on-demand. + + -- FIXME: we don't report needed units because we would have to find a way + -- to build a meaningful LoadedPkgInfo (see the mess in + -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load + -- and actually loading (using the native interpreter) are intermingled, so + -- we can't directly reuse this code. + let pls' = pls { objs_loaded = objs_loaded' } + pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) ) + + + let foreign_stubs = NoStubs + spt_entries = mempty + cost_centre_info = mempty + + -- codegen into object file whose path is in out_obj + out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o" + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj + + let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod + -- link code containing binding "id_sym = expr", using id_sym as root + withJSInterp i $ \inst -> do + let roots = mkExportedModFuns this_mod [id_sym] + jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots + + -- look up "id_sym" closure and create a StablePtr (HValue) from it + href <- lookupClosure interp (unpackFS id_sym) >>= \case + Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym) + Just r -> pure r + + binding_fref <- withJSInterp i $ \inst -> + mkForeignRef href (freeReallyRemoteRef inst href) + + return (castForeignRef binding_fref, dep_linkables, dep_units) {- ********************************************************************** 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 @@ -27,7 +27,7 @@ -- ----------------------------------------------------------------------------- module GHC.Driver.Make ( depanal, depanalE, depanalPartial, checkHomeUnitsClosed, - load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, + load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, instantiationNodes, downsweep, @@ -75,6 +75,7 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Main +import GHC.Driver.MakeSem import GHC.Parser.Header @@ -105,6 +106,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc +import GHC.Types.Unique.Map import GHC.Types.PkgQual import GHC.Unit @@ -129,6 +131,7 @@ import Data.IORef import Data.Maybe import Data.Time +import Data.List (sortOn) import Data.Bifunctor (first) import System.Directory import System.FilePath @@ -149,10 +152,10 @@ import GHC.Rename.Names import GHC.Utils.Constants import GHC.Types.Unique.DFM (udfmRestrictKeysSet) -import GHC.Types.Unique.Map import GHC.Types.Unique +import GHC.Iface.Errors.Types -import qualified GHC.Data.Word64Set as W +import qualified Data.IntSet as I -- ----------------------------------------------------------------------------- -- Loading the program @@ -308,16 +311,16 @@ -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Sometimes we don't want GHC to process modules that weren't specified as --- explicit targets. For example, cabal may want to enable this warning --- when building a library, so that GHC warns the user about modules listed --- neither in `exposed-modules` nor in `other-modules`. +-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed +-- in a command line. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns user about modules, not listed +-- neither in `exposed-modules`, nor in `other-modules`. -- --- Here "home module" means a module that doesn't come from another package. +-- Here "home module" means a module, that doesn't come from an other package. -- -- For example, if GHC is invoked with modules "A" and "B" as targets, -- but "A" imports some other module "C", then GHC will issue a warning --- about module "C" not being listed in the command line. +-- about module "C" not being listed in a command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages @@ -328,6 +331,8 @@ where diag_opts = initDiagOpts dflags + is_known_module mod = any (is_my_target mod) targets + -- We need to be careful to handle the case where (possibly -- path-qualified) filenames (aka 'TargetFile') rather than module -- names are being passed on the GHC command-line. @@ -336,31 +341,27 @@ -- `ghc --make -isrc-exe Main` are supposed to be equivalent. -- Note also that we can't always infer the associated module name -- directly from the filename argument. See #13727. - is_known_module mod = - is_module_target mod - || - maybe False is_file_target (ml_hs_file (ms_location mod)) - - is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets - - is_file_target file = Set.member (withoutExt file) file_targets - - file_targets = Set.fromList (mapMaybe file_target targets) - - file_target Target {targetId} = - case targetId of - TargetModule _ -> Nothing - TargetFile file _ -> - Just (withoutExt (augmentByWorkingDirectory dflags file)) - - mod_targets = Set.fromList (mod_target <$> targets) + is_my_target mod target = + let tuid = targetUnitId target + in case targetId target of + TargetModule name + -> moduleName (ms_mod mod) == name + && tuid == ms_unitid mod + TargetFile target_file _ + | Just mod_file <- ml_hs_file (ms_location mod) + -> + augmentByWorkingDirectory dflags target_file == mod_file || - mod_target Target {targetUnitId, targetId} = - case targetId of - TargetModule name -> (name, targetUnitId) - TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId) + -- Don't warn on B.hs-boot if B.hs is specified (#16551) + addBootSuffix target_file == mod_file || - withoutExt = fst . splitExtension + -- We can get a file target even if a module name was + -- originally specified in a command line because it can + -- be converted in guessTarget (by appending .hs/.lhs). + -- So let's convert it back and compare with module name + mkModuleName (fst $ splitExtension target_file) + == moduleName (ms_mod mod) + _ -> False missing = map (moduleName . ms_mod) $ filter (not . is_known_module) $ @@ -485,7 +486,7 @@ -- All other errors are reported using the 'defaultWarnErrLogger'. load :: GhcMonad f => LoadHowMuch -> f SuccessFlag -load how_much = loadWithCache noIfaceCache how_much +load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = @@ -494,12 +495,18 @@ then batchMultiMsg else batchMsg +type AnyGhcDiagnostic = UnknownDiagnostic (DiagnosticOpts GhcMessage) -loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag -loadWithCache cache how_much = do +loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them. + -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user. + -- If you are using the GHC API you can use this to override how messages + -- created during 'loadWithCache' are displayed to the user. + -> LoadHowMuch -- ^ How much `loadWithCache` should load + -> m SuccessFlag +loadWithCache cache diag_wrapper how_much = do (errs, mod_graph) <- depanalE [] False -- #17459 msg <- mkBatchMsg <$> getSession - success <- load' cache how_much (Just msg) mod_graph + success <- load' cache how_much diag_wrapper (Just msg) mod_graph if isEmptyMessages errs then pure success else throwErrors (fmap GhcDriverMessage errs) @@ -515,14 +522,18 @@ warnUnusedPackages us dflags mod_graph = let diag_opts = initDiagOpts dflags + home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph) + -- Only need non-source imports here because SOURCE imports are always HPT loadedPackages = concat $ mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs) - $ concatMap ms_imps ( - filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)) + $ concatMap ms_imps home_mod_sum - used_args = Set.fromList $ map unitId loadedPackages + any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum + used_args = Set.fromList (map unitId loadedPackages) + `Set.union` Set.fromList [ primUnitId | any_import_ghc_prim ] + resolve (u,mflag) = do -- The units which we depend on via the command line explicitly flag <- mflag @@ -532,7 +543,7 @@ guard (Set.notMember (unitId ui) used_args) return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag) - unusedArgs = mapMaybe resolve (explicitUnits us) + unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us) warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs) @@ -598,7 +609,7 @@ -- Now perform another toposort but just with these nodes and relevant hs-boot files. -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. mresolved_cycle = collapseSCC (topSortWithBoot nodes) - in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] + in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) trans_deps_map = allReachable mg (mkNodeKey . node_payload) @@ -629,12 +640,12 @@ get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing -- Any cycles should be resolved now - collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] + collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -- Must be at least two nodes, as we were in a cycle - collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] - collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes) + collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2] + collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes -- Cyclic - collapseSCC nodes = Left (flattenSCCs nodes) + collapseSCC _ = Nothing toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile toNodeWithBoot mn = @@ -660,18 +671,44 @@ (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))]) build_plan +mkWorkerLimit :: DynFlags -> IO WorkerLimit +mkWorkerLimit dflags = + case parMakeCount dflags of + Nothing -> pure $ num_procs 1 + Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h)) + Just ParMakeNumProcessors -> num_procs <$> getNumProcessors + Just (ParMakeThisMany n) -> pure $ num_procs n + where + num_procs x = NumProcessorsLimit (max 1 x) + +isWorkerLimitSequential :: WorkerLimit -> Bool +isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1 +isWorkerLimitSequential (JSemLimit {}) = False + +-- | This describes what we use to limit the number of jobs, either we limit it +-- ourselves to a specific number or we have an external parallelism semaphore +-- limit it for us. +data WorkerLimit + = NumProcessorsLimit Int + | JSemLimit + SemaphoreName + -- ^ Semaphore name to use + deriving Eq + -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally -- produced by calling 'depanal'. -load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' mhmi_cache how_much mHscMessage mod_graph = do +load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- In normal usage plugins are initialised already by ghc/Main.hs this is protective -- for any client who might interact with GHC via load'. + -- See Note [Timing of plugin initialization] initializeSessionPlugins modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession + let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let interp = hscInterp hsc_env @@ -735,7 +772,6 @@ let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env - hsc_env <- getSession -- Unload everything liftIO $ unload interp hsc_env @@ -743,13 +779,12 @@ liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep") 2 (ppr build_plan)) - n_jobs <- case parMakeCount (hsc_dflags hsc_env) of - Nothing -> liftIO getNumProcessors - Just n -> return n + worker_limit <- liftIO $ mkWorkerLimit dflags + setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession - liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan + liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan modifySession (addDepsToHscEnv new_deps) case upsweep_ok of Failed -> loadFinish upsweep_ok @@ -1032,13 +1067,7 @@ type BuildM a = StateT BuildLoopState IO a --- | Abstraction over the operations of a semaphore which allows usage with the --- -j1 case -data AbstractSem = AbstractSem { acquireSem :: IO () - , releaseSem :: IO () } -withAbstractSem :: AbstractSem -> IO b -> IO b -withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem) -- | Environment used when compiling a module data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module @@ -1049,6 +1078,7 @@ -- into the log queue. , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a , env_messager :: !(Maybe Messager) + , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic } type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a @@ -1116,37 +1146,33 @@ -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let !build_action = + let build_action = + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps case mod of InstantiationNode uid iu -> do - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> do let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - in withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $! (MakeAction build_action res_var) + return $ (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -1227,16 +1253,17 @@ local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)}) upsweep - :: Int -- ^ The number of workers we wish to run in parallel + :: WorkerLimit -- ^ The number of workers we wish to run in parallel -> HscEnv -- ^ The base HscEnv, which is augmented for each module -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to + -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> M.Map ModNodeKeyWithUid HomeModInfo -> [BuildPlan] -> IO (SuccessFlag, [HomeModInfo]) -upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do +upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan - runPipelines n_jobs hsc_env mHscMessage pipelines + runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines res <- collect_result let completed = [m | Just (Just m) <- res] @@ -1547,8 +1574,8 @@ let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 root_map = mkRootMap rootSummariesOk checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) + (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map) + let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1642,25 +1669,27 @@ -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit loopSummaries :: [ModSummary] - -> (M.Map NodeKey ModuleGraphNode, + -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId), DownsweepCache) - -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache) + -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache) loopSummaries [] done = return done - loopSummaries (ms:next) (done, summarised) + loopSummaries (ms:next) (done, pkgs, summarised) | Just {} <- M.lookup k done - = loopSummaries next (done, summarised) + = loopSummaries next (done, pkgs, summarised) -- Didn't work out what the imports mean yet, now do that. | otherwise = do - (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised + (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'') + (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'') where k = NodeKey_Module (msKey ms) hs_file_for_boot - | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) - | otherwise = Nothing + | HsBootFile <- ms_hsc_src ms + = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) + | otherwise + = Nothing -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover @@ -1672,17 +1701,18 @@ -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> IO ([NodeKey], + -> IO ([NodeKey], Set.Set (UnitId, UnitId), + M.Map NodeKey ModuleGraphNode, DownsweepCache) -- The result is the completed NodeMap - loopImports [] done summarised = return ([], done, summarised) + loopImports [] done summarised = return ([], Set.empty, done, summarised) loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised | Just summs <- M.lookup cache_key summarised = case summs of [Right ms] -> do let nk = NodeKey_Module (msKey ms) - (rest, summarised', done') <- loopImports ss done summarised - return (nk: rest, summarised', done') + (rest, pkgs, summarised', done') <- loopImports ss done summarised + return (nk: rest, pkgs, summarised', done') [Left _err] -> loopImports ss done summarised _errs -> do @@ -1694,79 +1724,69 @@ Nothing excl_mods case mb_s of NotThere -> loopImports ss done summarised - External _ -> do - (other_deps, done', summarised') <- loopImports ss done summarised - return (other_deps, done', summarised') + External uid -> do + (other_deps, pkgs, done', summarised') <- loopImports ss done summarised + return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised') FoundInstantiation iud -> do - (other_deps, done', summarised') <- loopImports ss done summarised - return (NodeKey_Unit iud : other_deps, done', summarised') + (other_deps, pkgs, done', summarised') <- loopImports ss done summarised + return (NodeKey_Unit iud : other_deps, pkgs, done', summarised') FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) FoundHome s -> do - (done', summarised') <- - loopSummaries [s] (done, Map.insert cache_key [Right s] summarised) - (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' + (done', pkgs1, summarised') <- + loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised) + (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised' -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised) + return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised) where cache_key = (home_uid, mb_pkg, unLoc <$> gwib) home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib wanted_mod = L loc mod --- | This function checks then important property that if both p and q are home units +-- This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. --- --- See Note [Multiple Home Units], section 'Closure Property'. -checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] -checkHomeUnitsClosed ue - | Set.null bad_unit_ids = [] - | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] +checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +-- Fast path, trivially closed. +checkHomeUnitsClosed ue home_id_set home_imp_ids + | Set.size home_id_set == 1 = [] + | otherwise = + let res = foldMap loop home_imp_ids + -- Now check whether everything which transitively depends on a home_unit is actually a home_unit + -- These units are the ones which we need to load as home packages but failed to do for some reason, + -- it's a bug in the tool invoking GHC. + bad_unit_ids = Set.difference res home_id_set + in if Set.null bad_unit_ids + then [] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + where - home_id_set = unitEnv_keys $ ue_home_unit_graph ue - bad_unit_ids = upwards_closure Set.\\ home_id_set rootLoc = mkGeneralSrcSpan (fsLit "") - - graph :: Graph (Node UnitId UnitId) - graph = graphFromEdgedVerticesUniq graphNodes - - -- downwards closure of graph - downwards_closure - = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps) - | (uid, deps) <- M.toList (allReachable graph node_key)] - - inverse_closure = transposeG downwards_closure - - upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] - - all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) - all_unit_direct_deps - = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue - where - go rest this this_uis = - plusUniqMap_C Set.union - (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) - rest - where - external_depends = mapUniqMap (Set.fromList . unitDepends) - $ listToUniqMap $ Map.toList - $ unitInfoMap this_units - this_units = homeUnitEnv_units this_uis - this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go Set.empty home_id_set - where - go done todo - = case Set.minView todo of - Nothing -> [] - Just (uid, todo') - | Set.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends Set.\\ done) `Set.union` todo' - in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' + -- TODO: This could repeat quite a bit of work but I struggled to write this function. + -- Which units transitively depend on a home unit + loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop (from_uid, uid) = + let us = ue_findHomeUnitEnv from_uid ue in + let um = unitInfoMap (homeUnitEnv_units us) in + case lookupUniqMap um uid of + Nothing -> pprPanic "uid not found" (ppr uid) + Just ui -> + let depends = unitDepends ui + home_depends = Set.fromList depends `Set.intersection` home_id_set + other_depends = Set.fromList depends `Set.difference` home_id_set + in + -- Case 1: The unit directly depends on a home_id + if not (null home_depends) + then + let res = foldMap (loop . (from_uid,)) other_depends + in Set.insert uid res + -- Case 2: Check the rest of the dependencies, and then see if any of them depended on + else + let res = foldMap (loop . (from_uid,)) other_depends + in + if not (Set.null res) + then Set.insert uid res + else res -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to @@ -2194,9 +2214,9 @@ -- annotation, but we don't know if it's a signature or a regular -- module until we actually look it up on the filesystem. let hsc_src - | is_boot == IsBoot = HsBootFile + | is_boot == IsBoot = HsBootFile | isHaskellSigFilename src_fn = HsigFile - | otherwise = HsSrcFile + | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc @@ -2348,8 +2368,8 @@ -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ - DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ - cannotFindModule hsc_env wanted_mod err + DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot)) {- noHsFileErr :: SrcSpan -> String -> DriverMessages @@ -2430,12 +2450,12 @@ hscUpdateHUG (const $ deps) hsc_env -- | Wrap an action to catch and handle exceptions. -wrapAction :: HscEnv -> IO a -> IO (Maybe a) -wrapAction hsc_env k = do +wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a) +wrapAction msg_wrapper hsc_env k = do let lcl_logger = hsc_logger hsc_env lcl_dynflags = hsc_dflags hsc_env print_config = initPrintConfig lcl_dynflags - let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err) + let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err) -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches` -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to @@ -2485,9 +2505,10 @@ -- Output of the logger is mediated by a central worker to -- avoid output interleaving msg <- asks env_messager + wrapper <- asks diag_wrapper lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> let lcl_hsc_env = setHUG deps hsc_env - in wrapAction lcl_hsc_env $ do + in wrapAction wrapper lcl_hsc_env $ do res <- upsweep_inst lcl_hsc_env msg k n uid iu cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) return res @@ -2513,7 +2534,7 @@ hydrated_hsc_env -- Compile the module, locking with a semaphore to avoid too many modules -- being compiled at the same time leading to high memory usage. - wrapAction lcl_hsc_env $ do + wrapAction diag_wrapper lcl_hsc_env $ do res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags return res) @@ -2525,7 +2546,7 @@ -- compiling a signature requires an knot_var for that unit. -- If you remove this then a lot of backpack tests fail. HsigFile -> Just [] - _ -> mrehydrate_mods + _ -> mrehydrate_mods {- Rehydration, see Note [Rehydrating Modules] -} @@ -2757,6 +2778,7 @@ link (ghcLink dflags) (hsc_logger hsc_env') (hsc_tmpfs hsc_env') + (hsc_FC hsc_env') (hsc_hooks hsc_env') dflags (hsc_unit_env hsc_env') @@ -2801,12 +2823,12 @@ -} -- See Note [ModuleNameSet, efficiency and space leaks] -type ModuleNameSet = M.Map UnitId W.Word64Set +type ModuleNameSet = M.Map UnitId I.IntSet addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet addToModuleNameSet uid mn s = let k = (getKey $ getUnique $ mn) - in M.insertWith (W.union) uid (W.singleton k) s + in M.insertWith (I.union) uid (I.singleton k) s -- | Wait for some dependencies to finish and then read from the given MVar. wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet) @@ -2817,7 +2839,7 @@ let -- Restrict to things which are in the transitive closure to avoid retaining -- reference to loop modules which have already been compiled by other threads. -- See Note [ModuleNameSet, efficiency and space leaks] - !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe W.empty $ M.lookup uid module_deps) + !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe I.empty $ M.lookup uid module_deps) in hme { homeUnitEnv_hpt = new } return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps) @@ -2832,7 +2854,7 @@ Nothing -> return (hmis, new_deps) Just hmi -> return (hmi:hmis, new_deps) where - unionModuleNameSet = M.unionWith W.union + unionModuleNameSet = M.unionWith I.union -- Executing the pipelines @@ -2844,32 +2866,55 @@ CC.labelThread self_tid thread_name -runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () +runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () -- Don't even initialise plugins if there are no pipelines -runPipelines _ _ _ [] = return () -runPipelines n_job hsc_env mHscMessager all_pipelines = do +runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" case n_job of - 1 -> runSeqPipelines hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job hsc_env mHscMessager all_pipelines + NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines + _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines -runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () -runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = +runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () +runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = let env = MakeEnv { hsc_env = plugin_hsc_env , withLogger = \_ k -> k id , compile_sem = AbstractSem (return ()) (return ()) , env_messager = mHscMessager + , diag_wrapper = diag_wrapper } - in runAllPipelines 1 env all_pipelines + in runAllPipelines (NumProcessorsLimit 1) env all_pipelines +runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a +runNjobsAbstractSem n_jobs action = do + compile_sem <- newQSem n_jobs + n_capabilities <- getNumCapabilities + n_cpus <- getNumProcessors + let + asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) + set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n + updNumCapabilities = do + -- Setting number of capabilities more than + -- CPU count usually leads to high userspace + -- lock contention. #9221 + set_num_caps $ min n_jobs n_cpus + resetNumCapabilities = set_num_caps n_capabilities + MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem +runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a +runWorkerLimit worker_limit action = case worker_limit of + NumProcessorsLimit n_jobs -> + runNjobsAbstractSem n_jobs action + JSemLimit sem -> + runJSemAbstractSem sem action + -- | Build and run a pipeline -runParPipelines :: Int -- ^ How many capabilities to use - -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module +runParPipelines :: WorkerLimit -- ^ How to limit work parallelism + -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module + -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -- ^ Optional custom messager to use to report progress -> [MakeAction] -- ^ The build plan for all the module nodes -> IO () -runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do +runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do -- A variable which we write to when an error has happened and we have to tell the @@ -2879,39 +2924,24 @@ -- will add it's LogQueue into this queue. log_queue_queue_var <- newTVarIO newLogQueueQueue -- Thread which coordinates the printing of logs - wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var + wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue. thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } - let updNumCapabilities = liftIO $ do - n_capabilities <- getNumCapabilities - n_cpus <- getNumProcessors - -- Setting number of capabilities more than - -- CPU count usually leads to high userspace - -- lock contention. #9221 - let n_caps = min n_jobs n_cpus - unless (n_capabilities /= 1) $ setNumCapabilities n_caps - return n_capabilities - - let resetNumCapabilities orig_n = do - liftIO $ setNumCapabilities orig_n - atomically $ writeTVar stopped_var True - wait_log_thread - - compile_sem <- newQSem n_jobs - let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) + runWorkerLimit worker_limit $ \abstract_sem -> do + let env = MakeEnv { hsc_env = thread_safe_hsc_env + , withLogger = withParLog log_queue_queue_var + , compile_sem = abstract_sem + , env_messager = mHscMessager + , diag_wrapper = diag_wrapper + } -- Reset the number of capabilities once the upsweep ends. - let env = MakeEnv { hsc_env = thread_safe_hsc_env - , withLogger = withParLog log_queue_queue_var - , compile_sem = abstract_sem - , env_messager = mHscMessager - } - - MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> - runAllPipelines n_jobs env all_pipelines + runAllPipelines worker_limit env all_pipelines + atomically $ writeTVar stopped_var True + wait_log_thread withLocalTmpFS :: RunMakeM a -> RunMakeM a withLocalTmpFS act = do @@ -2928,10 +2958,11 @@ MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act -- | Run the given actions and then wait for them all to finish. -runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO () -runAllPipelines n_jobs env acts = do - let spawn_actions :: IO [ThreadId] - spawn_actions = if n_jobs == 1 +runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO () +runAllPipelines worker_limit env acts = do + let single_worker = isWorkerLimitSequential worker_limit + spawn_actions :: IO [ThreadId] + spawn_actions = if single_worker then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts) else runLoop forkIOWithUnmask env acts @@ -2957,7 +2988,7 @@ run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) +data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar diff --git a/compiler/GHC/Driver/MakeSem.hs b/compiler/GHC/Driver/MakeSem.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/MakeSem.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | Implementation of a jobserver using system semaphores. +-- +-- +module GHC.Driver.MakeSem + ( -- * JSem: parallelism semaphore backed + -- by a system semaphore (Posix/Windows) + runJSemAbstractSem + + -- * System semaphores + , Semaphore, SemaphoreName(..) + + -- * Abstract semaphores + , AbstractSem(..) + , withAbstractSem + ) + where + +import GHC.Prelude +import GHC.Conc +import GHC.Data.OrdList +import GHC.IO.Exception +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Json + +import System.Semaphore + +import Control.Monad +import qualified Control.Monad.Catch as MC +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Data.Foldable +import Data.Functor +import GHC.Stack +import Debug.Trace + +--------------------------------------- +-- Semaphore jobserver + +-- | A jobserver based off a system 'Semaphore'. +-- +-- Keeps track of the pending jobs and resources +-- available from the semaphore. +data Jobserver + = Jobserver + { jSemaphore :: !Semaphore + -- ^ The semaphore which controls available resources + , jobs :: !(TVar JobResources) + -- ^ The currently pending jobs, and the resources + -- obtained from the semaphore + } + +data JobserverOptions + = JobserverOptions + { releaseDebounce :: !Int + -- ^ Minimum delay, in milliseconds, between acquiring a token + -- and releasing a token. + , setNumCapsDebounce :: !Int + -- ^ Minimum delay, in milliseconds, between two consecutive + -- calls of 'setNumCapabilities'. + } + +defaultJobserverOptions :: JobserverOptions +defaultJobserverOptions = + JobserverOptions + { releaseDebounce = 1000 -- 1 second + , setNumCapsDebounce = 1000 -- 1 second + } + +-- | Resources available for running jobs, i.e. +-- tokens obtained from the parallelism semaphore. +data JobResources + = Jobs + { tokensOwned :: !Int + -- ^ How many tokens have been claimed from the semaphore + , tokensFree :: !Int + -- ^ How many tokens are not currently being used + , jobsWaiting :: !(OrdList (TMVar ())) + -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into + -- the TMVar will allow the job to continue. + } + +instance Outputable JobResources where + ppr Jobs{..} + = text "JobResources" <+> + ( braces $ hsep + [ text "owned=" <> ppr tokensOwned + , text "free=" <> ppr tokensFree + , text "num_waiting=" <> ppr (length jobsWaiting) + ] ) + +-- | Add one new token. +addToken :: JobResources -> JobResources +addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free }) + = jobs { tokensOwned = owned + 1, tokensFree = free + 1 } + +-- | Free one token. +addFreeToken :: JobResources -> JobResources +addFreeToken jobs@( Jobs { tokensFree = free }) + = assertPpr (tokensOwned jobs > free) + (text "addFreeToken:" <+> ppr (tokensOwned jobs) <+> ppr free) + $ jobs { tokensFree = free + 1 } + +-- | Use up one token. +removeFreeToken :: JobResources -> JobResources +removeFreeToken jobs@( Jobs { tokensFree = free }) + = assertPpr (free > 0) + (text "removeFreeToken:" <+> ppr free) + $ jobs { tokensFree = free - 1 } + +-- | Return one owned token. +removeOwnedToken :: JobResources -> JobResources +removeOwnedToken jobs@( Jobs { tokensOwned = owned }) + = assertPpr (owned > 1) + (text "removeOwnedToken:" <+> ppr owned) + $ jobs { tokensOwned = owned - 1 } + +-- | Add one new job to the end of the list of pending jobs. +addJob :: TMVar () -> JobResources -> JobResources +addJob job jobs@( Jobs { jobsWaiting = wait }) + = jobs { jobsWaiting = wait `SnocOL` job } + +-- | The state of the semaphore job server. +data JobserverState + = JobserverState + { jobserverAction :: !JobserverAction + -- ^ The current action being performed by the + -- job server. + , canChangeNumCaps :: !(TVar Bool) + -- ^ A TVar that signals whether it has been long + -- enough since we last changed 'numCapabilities'. + , canReleaseToken :: !(TVar Bool) + -- ^ A TVar that signals whether we last acquired + -- a token long enough ago that we can now release + -- a token. + } +data JobserverAction + -- | The jobserver is idle: no thread is currently + -- interacting with the semaphore. + = Idle + -- | A thread is waiting for a token on the semaphore. + | Acquiring + { activeWaitId :: WaitId + , threadFinished :: TMVar (Maybe MC.SomeException) } + +-- | Retrieve the 'TMVar' that signals if the current thread has finished, +-- if any thread is currently active in the jobserver. +activeThread_maybe :: JobserverAction -> Maybe (TMVar (Maybe MC.SomeException)) +activeThread_maybe Idle = Nothing +activeThread_maybe (Acquiring { threadFinished = tmvar }) = Just tmvar + +-- | Whether we should try to acquire a new token from the semaphore: +-- there is a pending job and no free tokens. +guardAcquire :: JobResources -> Bool +guardAcquire ( Jobs { tokensFree, jobsWaiting } ) + = tokensFree == 0 && not (null jobsWaiting) + +-- | Whether we should release a token from the semaphore: +-- there are no pending jobs and we can release a token. +guardRelease :: JobResources -> Bool +guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } ) + = null jobsWaiting && tokensFree > 0 && tokensOwned > 1 + +--------------------------------------- +-- Semaphore jobserver implementation + +-- | Add one pending job to the jobserver. +-- +-- Blocks, waiting on the jobserver to supply a free token. +acquireJob :: TVar JobResources -> IO () +acquireJob jobs_tvar = do + (job_tmvar, _jobs0) <- tracedAtomically "acquire" $ + modifyJobResources jobs_tvar \ jobs -> do + job_tmvar <- newEmptyTMVar + return ((job_tmvar, jobs), addJob job_tmvar jobs) + atomically $ takeTMVar job_tmvar + +-- | Signal to the job server that one job has completed, +-- releasing its corresponding token. +releaseJob :: TVar JobResources -> IO () +releaseJob jobs_tvar = do + tracedAtomically "release" do + modifyJobResources jobs_tvar \ jobs -> do + massertPpr (tokensFree jobs < tokensOwned jobs) + (text "releaseJob: more free jobs than owned jobs!") + return ((), addFreeToken jobs) + + +-- | Release all tokens owned from the semaphore (to clean up +-- the jobserver at the end). +cleanupJobserver :: Jobserver -> IO () +cleanupJobserver (Jobserver { jSemaphore = sem + , jobs = jobs_tvar }) + = do + Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar + let toks_to_release = owned - 1 + -- Subtract off the implicit token: whoever spawned the ghc process + -- in the first place is responsible for that token. + releaseSemaphore sem toks_to_release + +-- | Dispatch the available tokens acquired from the semaphore +-- to the pending jobs in the job server. +dispatchTokens :: JobResources -> STM JobResources +dispatchTokens jobs@( Jobs { tokensFree = toks_free, jobsWaiting = wait } ) + | toks_free > 0 + , next `ConsOL` rest <- wait + -- There's a pending job and a free token: + -- pass on the token to that job, and recur. + = do + putTMVar next () + let jobs' = jobs { tokensFree = toks_free - 1, jobsWaiting = rest } + dispatchTokens jobs' + | otherwise + = return jobs + +-- | Update the available resources used from a semaphore, dispatching +-- any newly acquired resources. +-- +-- Invariant: if the number of available resources decreases, there +-- must be no pending jobs. +-- +-- All modifications should go through this function to ensure the contents +-- of the 'TVar' remains in normal form. +modifyJobResources :: HasCallStack => TVar JobResources + -> (JobResources -> STM (a, JobResources)) + -> STM (a, Maybe JobResources) +modifyJobResources jobs_tvar action = do + old_jobs <- readTVar jobs_tvar + (a, jobs) <- action old_jobs + + -- Check the invariant: if the number of free tokens has decreased, + -- there must be no pending jobs. + massertPpr (null (jobsWaiting jobs) || tokensFree jobs >= tokensFree old_jobs) $ + vcat [ text "modiyJobResources: pending jobs but fewer free tokens" ] + dispatched_jobs <- dispatchTokens jobs + writeTVar jobs_tvar dispatched_jobs + return (a, Just dispatched_jobs) + + +tracedAtomically_ :: String -> STM (Maybe JobResources) -> IO () +tracedAtomically_ s act = tracedAtomically s (((),) <$> act) + +tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a +tracedAtomically origin act = do + (a, mjr) <- atomically act + forM_ mjr $ \ jr -> do + -- Use the "jsem:" prefix to identify where the write traces are + traceEventIO ("jsem:" ++ renderJobResources origin jr) + return a + +renderJobResources :: String -> JobResources -> String +renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $ + JSObject [ ("name", JSString origin) + , ("owned", JSInt own) + , ("free", JSInt free) + , ("pending", JSInt (length pending) ) + ] + + +-- | Spawn a new thread that waits on the semaphore in order to acquire +-- an additional token. +acquireThread :: Jobserver -> IO JobserverAction +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do + threadFinished_tmvar <- newEmptyTMVarIO + let + wait_result_action :: Either MC.SomeException Bool -> IO () + wait_result_action wait_res = + tracedAtomically_ "acquire_thread" do + (r, jb) <- case wait_res of + Left (e :: MC.SomeException) -> do + return $ (Just e, Nothing) + Right success -> do + if success + then do + modifyJobResources jobs_tvar \ jobs -> + return (Nothing, addToken jobs) + else + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jb + wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action + labelThread (waitingThreadId wait_id) "acquire_thread" + return $ Acquiring { activeWaitId = wait_id + , threadFinished = threadFinished_tmvar } + +-- | Spawn a thread to release ownership of one resource from the semaphore, +-- provided we have spare resources and no pending jobs. +releaseThread :: Jobserver -> IO JobserverAction +releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do + threadFinished_tmvar <- newEmptyTMVarIO + MC.mask_ do + -- Pre-release the resource so that another thread doesn't take control of it + -- just as we release the lock on the semaphore. + still_ok_to_release + <- tracedAtomically "pre_release" $ + modifyJobResources jobs_tvar \ jobs -> + if guardRelease jobs + -- TODO: should this also debounce? + then return (True , removeOwnedToken $ removeFreeToken jobs) + else return (False, jobs) + if not still_ok_to_release + then return Idle + else do + tid <- forkIO $ do + x <- MC.try $ releaseSemaphore sem 1 + tracedAtomically_ "post-release" $ do + (r, jobs) <- case x of + Left (e :: MC.SomeException) -> do + modifyJobResources jobs_tvar \ jobs -> + return (Just e, addToken jobs) + Right _ -> do + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jobs + labelThread tid "release_thread" + return Idle + +-- | When there are pending jobs but no free tokens, +-- spawn a thread to acquire a new token from the semaphore. +-- +-- See 'acquireThread'. +tryAcquire :: JobserverOptions + -> Jobserver + -> JobserverState + -> STM (IO JobserverState) +tryAcquire opts js@( Jobserver { jobs = jobs_tvar }) + st@( JobserverState { jobserverAction = Idle } ) + = do + jobs <- readTVar jobs_tvar + guard $ guardAcquire jobs + return do + action <- acquireThread js + -- Set a debounce after acquiring a token. + can_release_tvar <- registerDelay $ (releaseDebounce opts * 1000) + return $ st { jobserverAction = action + , canReleaseToken = can_release_tvar } +tryAcquire _ _ _ = retry + +-- | When there are free tokens and no pending jobs, +-- spawn a thread to release a token from the semamphore. +-- +-- See 'releaseThread'. +tryRelease :: Jobserver + -> JobserverState + -> STM (IO JobserverState) +tryRelease sjs@( Jobserver { jobs = jobs_tvar } ) + st@( JobserverState + { jobserverAction = Idle + , canReleaseToken = can_release_tvar } ) + = do + jobs <- readTVar jobs_tvar + guard $ guardRelease jobs + can_release <- readTVar can_release_tvar + guard can_release + return do + action <- releaseThread sjs + return $ st { jobserverAction = action } +tryRelease _ _ = retry + +-- | Wait for an active thread to finish. Once it finishes: +-- +-- - set the 'JobserverAction' to 'Idle', +-- - update the number of capabilities to reflect the number +-- of owned tokens from the semaphore. +tryNoticeIdle :: JobserverOptions + -> TVar JobResources + -> JobserverState + -> STM (IO JobserverState) +tryNoticeIdle opts jobs_tvar jobserver_state + | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state + = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar + | otherwise + = retry -- no active thread: wait until jobserver isn't idle + where + sync_num_caps :: TVar Bool + -> TMVar (Maybe MC.SomeException) + -> STM (IO JobserverState) + sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do + mb_ex <- takeTMVar threadFinished_tmvar + for_ mb_ex MC.throwM + Jobs { tokensOwned } <- readTVar jobs_tvar + can_change_numcaps <- readTVar can_change_numcaps_tvar + guard can_change_numcaps + return do + x <- getNumCapabilities + can_change_numcaps_tvar_2 <- + if x == tokensOwned + then return can_change_numcaps_tvar + else do + setNumCapabilities tokensOwned + registerDelay $ (setNumCapsDebounce opts * 1000) + return $ + jobserver_state + { jobserverAction = Idle + , canChangeNumCaps = can_change_numcaps_tvar_2 } + +-- | Try to stop the current thread which is acquiring/releasing resources +-- if that operation is no longer relevant. +tryStopThread :: TVar JobResources + -> JobserverState + -> STM (IO JobserverState) +tryStopThread jobs_tvar jsj = do + case jobserverAction jsj of + Acquiring { activeWaitId = wait_id } -> do + jobs <- readTVar jobs_tvar + guard $ null (jobsWaiting jobs) + return do + interruptWaitOnSemaphore wait_id + return $ jsj { jobserverAction = Idle } + _ -> retry + +-- | Main jobserver loop: acquire/release resources as +-- needed for the pending jobs and available semaphore tokens. +jobserverLoop :: JobserverOptions -> Jobserver -> IO () +jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar }) + = do + true_tvar <- newTVarIO True + let init_state :: JobserverState + init_state = + JobserverState + { jobserverAction = Idle + , canChangeNumCaps = true_tvar + , canReleaseToken = true_tvar } + loop init_state + where + loop s = do + action <- atomically $ asum $ (\x -> x s) <$> + [ tryRelease sjs + , tryAcquire opts sjs + , tryNoticeIdle opts jobs_tvar + , tryStopThread jobs_tvar + ] + s <- action + loop s + +-- | Create a new jobserver using the given semaphore handle. +makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ()) +makeJobserver sem_name = do + semaphore <- openSemaphore sem_name + let + init_jobs = + Jobs { tokensOwned = 1 + , tokensFree = 1 + , jobsWaiting = NilOL + } + jobs_tvar <- newTVarIO init_jobs + let + opts = defaultJobserverOptions -- TODO: allow this to be configured + sjs = Jobserver { jSemaphore = semaphore + , jobs = jobs_tvar } + loop_finished_mvar <- newEmptyMVar + loop_tid <- forkIOWithUnmask \ unmask -> do + r <- try $ unmask $ jobserverLoop opts sjs + putMVar loop_finished_mvar $ + case r of + Left e + | Just ThreadKilled <- fromException e + -> Nothing + | otherwise + -> Just e + Right () -> Nothing + labelThread loop_tid "job_server" + let + acquireSem = acquireJob jobs_tvar + releaseSem = releaseJob jobs_tvar + cleanupSem = do + -- this is interruptible + cleanupJobserver sjs + killThread loop_tid + mb_ex <- takeMVar loop_finished_mvar + for_ mb_ex MC.throwM + + return (AbstractSem{..}, cleanupSem) + +-- | Implement an abstract semaphore using a semaphore 'Jobserver' +-- which queries the system semaphore of the given name for resources. +runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use + -> (AbstractSem -> IO a) -- ^ the operation to run + -- which requires a semaphore + -> IO a +runJSemAbstractSem sem action = MC.mask \ unmask -> do + (abs, cleanup) <- makeJobserver sem + r <- try $ unmask $ action abs + case r of + Left (e1 :: MC.SomeException) -> do + (_ :: Either MC.SomeException ()) <- MC.try cleanup + MC.throwM e1 + Right x -> cleanup $> x + +{- Note [Architecture of the Job Server] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `-jsem` mode, the amount of parallelism that GHC can use is controlled by a +system semaphore. We take resources from the semaphore when we need them, and +give them back if we don't have enough to do. + +A naive implementation would just take and release the semaphore around performing +the action, but this leads to two issues: + +* When taking a token in the semaphore, we must call `setNumCapabilities` in order + to adjust how many capabilities are available for parallel garbage collection. + This causes unnecessary synchronisations. +* We want to implement a debounce, so that whilst there is pending work in the + current process we prefer to keep hold of resources from the semaphore. + This reduces overall memory usage, as there are fewer live GHC processes at once. + +Therefore, the obtention of semaphore resources is separated away from the +request for the resource in the driver. + +A token from the semaphore is requested using `acquireJob`. This creates a pending +job, which is a MVar that can be filled in to signal that the requested token is ready. + +When the job is finished, the token is released by calling `releaseJob`, which just +increases the number of `free` jobs. If there are more pending jobs when the free count +is increased, the token is immediately reused (see `modifyJobResources`). + +The `jobServerLoop` interacts with the system semaphore: when there are pending +jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a +token is obtained, it increases the owned count. + +When GHC has free tokens (tokens from the semaphore that it is not using), +no pending jobs, and the debounce has expired, then `releaseThread` will +release tokens back to the global semaphore. + +`tryStopThread` attempts to kill threads which are waiting to acquire a resource +when we no longer need it. For example, consider that we attempt to acquire two +tokens, but the first job finishes before we acquire the second token. +This second token is no longer needed, so we should cancel the wait +(as it would not be used to do any work, and not be returned until the debounce). +We only need to kill `acquireJob`, because `releaseJob` never blocks. + +Note [Eventlog Messages for jsem] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be tricky to verify that the work is shared adequately across different +processes. To help debug this, we output the values of `JobResource` to the +eventlog whenever the global state changes. There are some scripts which can be used +to analyse this output and report statistics about core saturation in the +GitHub repo (https://github.com/mpickering/ghc-jsem-analyse). + +-} 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 @@ -103,7 +103,7 @@ import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) ) -import GHC.Types.Error ( singleMessage, getMessages, UnknownDiagnostic (..) ) +import GHC.Types.Error ( singleMessage, getMessages, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts ) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -111,7 +111,7 @@ import GHC.Unit import GHC.Unit.Env ---import GHC.Unit.Finder +import GHC.Unit.Finder --import GHC.Unit.State import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface @@ -129,7 +129,6 @@ import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp -import GHC.Types.Unique.DSet -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m @@ -163,7 +162,7 @@ handler (ProgramError msg) = return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope srcspan $ - DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text msg + DriverUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError noHints $ text msg handler ex = throwGhcExceptionIO ex to_driver_messages :: Messages GhcMessage -> Messages DriverMessage @@ -352,6 +351,7 @@ link :: GhcLink -- ^ interactive or batch -> Logger -- ^ Logger -> TmpFs + -> FinderCache -> Hooks -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment @@ -367,7 +367,7 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt = +link ghcLink logger tmpfs fc hooks dflags unit_env batch_attempt_linking mHscMessage hpt = case linkHook hooks of Nothing -> case ghcLink of NoLink -> return Succeeded @@ -383,7 +383,7 @@ -> panicBadLink LinkInMemory Just h -> h ghcLink dflags batch_attempt_linking hpt where - normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt + normal_link = link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessage hpt panicBadLink :: GhcLink -> a @@ -392,6 +392,7 @@ link' :: Logger -> TmpFs + -> FinderCache -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? @@ -399,7 +400,7 @@ -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt +link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt | batch_attempt_linking = do let @@ -446,7 +447,7 @@ -- Don't showPass in Batch mode; doLink will do that for us. case ghcLink dflags of LinkBinary - | backendUseJSLinker (backend dflags) -> linkJSBinary logger dflags unit_env obj_files pkg_deps + | backendUseJSLinker (backend dflags) -> linkJSBinary logger fc dflags unit_env obj_files pkg_deps | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps @@ -463,14 +464,14 @@ return Succeeded -linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkJSBinary logger dflags unit_env obj_files pkg_deps = do +linkJSBinary :: Logger -> FinderCache -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkJSBinary logger fc dflags unit_env obj_files pkg_deps = do -- we use the default configuration for now. In the future we may expose -- settings to the user via DynFlags. let lc_cfg = defaultJSLinkConfig let cfg = initStgToJSConfig dflags let extra_js = mempty - jsLinkBinary lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps + jsLinkBinary fc lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do @@ -496,18 +497,8 @@ -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - -- pkg_deps is just the direct dependencies so take the transitive closure here - -- to decide if we need to relink or not. - let pkg_hslibs acc uid - | uid `elementOfUniqDSet` acc = acc - | Just c <- lookupUnitId unit_state uid = - foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c) - | otherwise = acc - - all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps - let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) - | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps), + | Just c <- map (lookupUnitId unit_state) pkg_deps, lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs @@ -542,6 +533,7 @@ -- In oneshot mode, initialise plugins specified on command line -- we also initialise in ghc/Main but this might be used as an entry point by API clients who -- should initialise their own plugins but may not. + -- See Note [Timing of plugin initialization] hsc_env <- initializePlugins orig_hsc_env o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs case stop_phase of @@ -552,28 +544,28 @@ compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) compileFile hsc_env stop_phase (src, mb_phase) = do - let offset_file = augmentByWorkingDirectory dflags src - dflags = hsc_dflags hsc_env - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - notStopPreprocess | StopPreprocess <- stop_phase = False - | _ <- stop_phase = True - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile - -- avoid -E -fno-code undesirable interactions. see #20439 - | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - pipe_env = mkPipeEnv stop_phase offset_file mb_phase output - pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase - - exists <- doesFileExist offset_file + exists <- doesFileExist src when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file)) + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + notStopPreprocess | StopPreprocess <- stop_phase = False + | _ <- stop_phase = True + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile + -- avoid -E -fno-code undesirable interactions. see #20439 + | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + pipe_env = mkPipeEnv stop_phase src mb_phase output + pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase runPipeline (hsc_hooks hsc_env) pipeline @@ -584,12 +576,13 @@ logger = hsc_logger hsc_env unit_env = hsc_unit_env hsc_env tmpfs = hsc_tmpfs hsc_env + fc = hsc_FC hsc_env case ghcLink dflags of NoLink -> return () LinkBinary | backendUseJSLinker (backend dflags) - -> linkJSBinary logger dflags unit_env o_files [] + -> linkJSBinary logger fc dflags unit_env o_files [] | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] @@ -747,7 +740,7 @@ let print_config = initPrintConfig dflags3 liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) - liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3) + liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcDriverMessage <$> warns3)) return (dflags3, pp_fn) @@ -879,9 +872,8 @@ use (T_ForeignJs pipe_env hsc_env location input_fn) hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) -hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing -hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing -hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn = +hscPostBackendPipeline _ _ (HsBootOrSig _) _ _ _ = return Nothing +hscPostBackendPipeline pipe_env hsc_env HsSrcFile bcknd ml input_fn = applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn applyPostHscPipeline diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -28,7 +28,6 @@ import GHC.Unit.Module.ModIface import GHC.Driver.Backend import GHC.Driver.Session -import GHC.Driver.CmdLine import GHC.Unit.Module.ModSummary import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc @@ -293,11 +292,7 @@ -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) - let (as_prog, get_asm_info) = - ( applyAssemblerProg $ backendAssemblerProg (backend dflags) - , applyAssemblerInfoGetter $ backendAssemblerInfoGetter (backend dflags) - ) - asmInfo <- get_asm_info logger dflags platform + let as_prog = applyAssemblerProg $ backendAssemblerProg (backend dflags) let cmdline_include_paths = includePaths dflags let pic_c_flags = picCCOpts dflags @@ -331,9 +326,6 @@ ++ [ GHC.SysTools.Option "-Wa,--no-type-check" | platformArch (targetPlatform dflags) == ArchWasm32] - ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51] - then [GHC.SysTools.Option "-Qunused-arguments"] - else []) ++ [ GHC.SysTools.Option "-x" , if with_cpp then GHC.SysTools.Option "assembler-with-cpp" @@ -401,19 +393,6 @@ return output_fn -applyAssemblerInfoGetter - :: DefunctionalizedAssemblerInfoGetter - -> Logger -> DynFlags -> Platform -> IO CompilerInfo -applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform = - getAssemblerInfo logger dflags -applyAssemblerInfoGetter JSAssemblerInfoGetter _ _ _ = - pure Emscripten -applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform = - if platformOS platform == OSDarwin then - pure Clang - else - getAssemblerInfo logger dflags - applyAssemblerProg :: DefunctionalizedAssemblerProg -> Logger -> DynFlags -> Platform -> [Option] -> IO () @@ -683,7 +662,7 @@ return output_fn -getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn])) +getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage)) getFileArgs hsc_env input_fn = do let dflags0 = hsc_dflags hsc_env parser_opts = initParserOpts dflags0 @@ -1028,6 +1007,7 @@ ++ ["+avx512cd"| isAvx512cdEnabled dflags ] ++ ["+avx512er"| isAvx512erEnabled dflags ] ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + ++ ["+fma" | isFmaEnabled dflags ] ++ ["+bmi" | isBmiEnabled dflags ] ++ ["+bmi2" | isBmi2Enabled dflags ] @@ -1039,9 +1019,8 @@ -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase -hscPostBackendPhase HsBootFile _ = StopLn -hscPostBackendPhase HsigFile _ = StopLn -hscPostBackendPhase _ bcknd = backendNormalSuccessorPhase bcknd +hscPostBackendPhase (HsBootOrSig _) _ = StopLn +hscPostBackendPhase HsSrcFile bcknd = backendNormalSuccessorPhase bcknd compileStub :: HscEnv -> FilePath -> IO FilePath @@ -1094,17 +1073,13 @@ The command used for object linking is set using the -pgmlm and -optlm command-line options. -However, `ld -r` is broken in some cases: - - * The LLD linker that we use on Windows does not support the `-r` - flag needed to support object merging (see #21068). For this reason - on Windows we do not support GHCi objects. - -In these cases, we bundle a module's own object file with its foreign -stub's object file, instead of merging them. Consequently, we can end -up producing `.o` files which are in fact static archives. This can -only work if `ar -L` is supported, so the archive `.o` files can be -properly added to the final static library. +Sadly, the LLD linker that we use on Windows does not support the `-r` flag +needed to support object merging (see #21068). For this reason on Windows we do +not support GHCi objects. To deal with foreign stubs we build a static archive +of all of a module's object files instead merging them. Consequently, we can +end up producing `.o` files which are in fact static archives. However, +toolchains generally don't have a problem with this as they use file headers, +not the filename, to determine the nature of inputs. Note that this has somewhat non-obvious consequences when producing initializers and finalizers. See Note [Initializers and finalizers in Cmm] @@ -1130,7 +1105,7 @@ -- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () joinObjectFiles hsc_env o_files output_fn - | can_merge_objs = do + | can_merge_objs && not dashLSupported = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) ( diff --git a/compiler/GHC/Driver/Pipeline/LogQueue.hs b/compiler/GHC/Driver/Pipeline/LogQueue.hs --- a/compiler/GHC/Driver/Pipeline/LogQueue.hs +++ b/compiler/GHC/Driver/Pipeline/LogQueue.hs @@ -100,10 +100,10 @@ Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq') _ -> Nothing -logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit +logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit -> TVar LogQueueQueue -- Queue for logs -> IO (IO ()) -logThread _ _ logger stopped lqq_var = do +logThread logger stopped lqq_var = do finished_var <- newEmptyMVar _ <- forkIO $ print_logs *> putMVar finished_var () return (takeMVar finished_var) diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -77,7 +77,13 @@ hsLitType (HsInt _ _) = intTy hsLitType (HsIntPrim _ _) = intPrimTy hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt8Prim _ _) = int8PrimTy +hsLitType (HsInt16Prim _ _) = int16PrimTy +hsLitType (HsInt32Prim _ _) = int32PrimTy hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord8Prim _ _) = word8PrimTy +hsLitType (HsWord16Prim _ _) = word16PrimTy +hsLitType (HsWord32Prim _ _) = word32PrimTy hsLitType (HsWord64Prim _ _) = word64PrimTy hsLitType (HsInteger _ _ ty) = ty hsLitType (HsRat _ _ ty) = ty diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -18,7 +18,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) import GHC.Driver.Config.HsToCore.Ticks @@ -167,7 +167,7 @@ [ (i, s) | i <- hsc_interp hsc_env , (_, s) <- m_tickInfo - , backendWantsBreakpointTicks (backend dflags) + , breakpointsAllowed dflags ] $ \(interp, specs) -> mkModBreaks interp mod specs @@ -182,8 +182,8 @@ _ -> pure $ emptyHpcInfo other_hpc_info ; (msgs, mb_res) <- initDs hsc_env tcg_env $ - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds binds_cvr + do { dsEvBinds ev_binds $ \ ds_ev_binds -> do + { core_prs <- dsTopLHsBinds binds_cvr ; core_prs <- patchMagicDefns core_prs ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (ds_fords, foreign_prs) <- dsForeigns fords @@ -194,7 +194,7 @@ ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules - , ds_fords `appendStubC` hpc_init) } + , ds_fords `appendStubC` hpc_init) } } ; case mb_res of { Nothing -> return (msgs, Nothing) ; @@ -764,7 +764,7 @@ unsafe_equality k a b = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a] , mkTyConApp unsafe_equality_tc [k,b,a] - , mkHeteroPrimEqPred k k a b + , mkNomPrimEqPred k a b ) -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to -- carefully swap the arguments above 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 @@ -158,9 +158,9 @@ -- = case v of v { (x1, .., xn) -> body } -- But the matching may be nested if the tuple is very big -coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr -coreCaseTuple uniqs scrut_var vars body - = mkBigTupleCase uniqs vars body (Var scrut_var) +coreCaseTuple :: Id -> [Id] -> CoreExpr -> DsM CoreExpr +coreCaseTuple scrut_var vars body + = mkBigTupleCase vars body (Var scrut_var) coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body @@ -231,9 +231,8 @@ -> CoreExpr -- e -> DsM CoreExpr matchEnvStack env_ids stack_id body = do - uniqs <- newUniqueSupply tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) - let match_env = coreCaseTuple uniqs tup_var env_ids body + match_env <- coreCaseTuple tup_var env_ids body pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) @@ -250,9 +249,9 @@ -> CoreExpr -- e -> DsM CoreExpr matchEnv env_ids body = do - uniqs <- newUniqueSupply tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) - return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) + tup_case <- coreCaseTuple tup_id env_ids body + return (Lam tup_id tup_case) ---------------------------------------------- -- matchVarStack @@ -511,7 +510,7 @@ let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase noExtField exp match') + core_body <- dsExpr (HsCase (ArrowMatchCtxt ArrowCaseAlt) exp match') core_matches <- matchEnvStack env_ids stack_id core_body return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, @@ -644,10 +643,10 @@ dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - core_wrap <- dsHsWrapper wrap - return (core_wrap core_cmd, env_ids') + dsHsWrapper wrap $ \core_wrap -> + return (core_wrap core_cmd, env_ids') -dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c) +dsCmd _ _ _ _ c@(HsCmdLam {}) _ = pprPanic "dsCmd" (ppr c) -- D; ys |-a c : stk --> t (ys <= xs) -- --------------------- @@ -812,7 +811,7 @@ Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> dsExpr (HsLamCase EpAnnNotUsed LamCase (MG { mg_alts = noLocA [] - , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated SkipPmc) })) -- Replace the commands in the case with these tagged tuples, @@ -957,11 +956,10 @@ -- \ (p, (xs2)) -> (zs) env_id <- newSysLocalDs ManyTy env_ty2 - uniqs <- newUniqueSupply let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids) fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty pat_id <- selectSimpleMatchVarL ManyTy pat @@ -1029,12 +1027,11 @@ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - uniqs <- newUniqueSupply env2_id <- newSysLocalDs ManyTy env2_ty let later_ty = mkBigCoreVarTupTy later_ids post_pair_ty = mkCorePairTy later_ty env2_ty - post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) + post_loop_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids) post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body @@ -1194,7 +1191,7 @@ -- Match a list of expressions against a list of patterns, left-to-right. matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext GhcRn -- Match kind + -> HsMatchContext GhcTc -- Match kind -> [LPat GhcTc] -- Patterns they should match -> CoreExpr -- Return this if they all match -> CoreExpr -- Return this if they don't 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 @@ -16,14 +16,14 @@ module GHC.HsToCore.Binds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec - , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds + , dsHsWrapper, dsHsWrappers, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds , dsWarnOrphanRule ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module @@ -41,6 +41,7 @@ import GHC.Core -- lots of things import GHC.Core.SimpleOpt ( simpleOptExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.InstEnv ( Canonical ) import GHC.Core.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( etaExpand ) @@ -60,6 +61,7 @@ import GHC.Tc.Types.Evidence import GHC.Types.Id +import GHC.Types.Id.Make ( nospecId ) import GHC.Types.Name import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -72,6 +74,7 @@ import GHC.Data.OrdList import GHC.Data.Graph.Directed import GHC.Data.Bag +import qualified Data.Set as S import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc @@ -153,7 +156,8 @@ , fun_matches = matches , fun_ext = (co_fn, tick) }) - = do { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $ + = do { dsHsWrapper co_fn $ \core_wrap -> do + { (args, body) <- addTyCs 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 @@ -163,7 +167,6 @@ -- See Note [Long-distance information] in "GHC.HsToCore.Pmc" matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches - ; core_wrap <- dsHsWrapper co_fn ; let body' = mkOptTickBox tick body rhs = core_wrap (mkLams args body') core_binds@(id,_) = makeCorePair dflags fun False 0 rhs @@ -179,7 +182,7 @@ ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) -- , ppr (mg_alts matches) -- , ppr args, ppr core_binds, ppr body']) $ - return (force_var, [core_binds]) } + return (force_var, [core_binds]) } } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss , pat_ext = (ty, (rhs_tick, var_ticks)) @@ -208,10 +211,10 @@ -- for inner pattern match check -- See Check, Note [Long-distance information] - ; ds_ev_binds <- dsTcEvBinds_s ev_binds + ; dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do -- dsAbsBinds does the hard work - ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } + { dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } } dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" @@ -241,9 +244,8 @@ _ -> Nothing -- If there is a variable to force, it's just the -- single variable we are binding here - = do { core_wrap <- dsHsWrapper wrap -- Usually the identity - - ; let rhs = core_wrap $ + = do { dsHsWrapper wrap $ \core_wrap -> do -- Usually the identity + { let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ mkCoreLets ds_ev_binds $ body @@ -261,7 +263,7 @@ (isDefaultMethod prags) (dictArity dicts) rhs - ; return (force_vars', main_bind : fromOL spec_binds) } + ; return (force_vars', main_bind : fromOL spec_binds) } } -- Another common case: no tyvars, no dicts -- In this case we can have a much simpler desugaring @@ -273,9 +275,9 @@ , abe_wrap = wrap }) -- No SpecPrags (no dicts) -- Can't be a default method (default methods are singletons) - = do { core_wrap <- dsHsWrapper wrap - ; return ( gbl_id `setInlinePragma` defaultInlinePragma - , core_wrap (Var lcl_id)) } + = do { dsHsWrapper wrap $ \core_wrap -> do + { return ( gbl_id `setInlinePragma` defaultInlinePragma + , core_wrap (Var lcl_id)) } } ; main_prs <- mapM mk_main exports ; return (force_vars, flattenBinds ds_ev_binds @@ -307,10 +309,10 @@ ; let mk_bind (ABE { abe_wrap = wrap , abe_poly = global , abe_mono = local, abe_prags = spec_prags }) - -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds" + -- See Note [ABExport wrapper] in "GHC.Hs.Binds" = do { tup_id <- newSysLocalDs ManyTy tup_ty - ; core_wrap <- dsHsWrapper wrap - ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ + ; dsHsWrapper wrap $ \core_wrap -> do + { let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ mkBigTupleSelector all_locals local tup_id $ mkVarApps (Var poly_tup_id) (tyvars ++ dicts) rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs @@ -320,7 +322,7 @@ -- Kill the INLINE pragma because it applies to -- the user written (local) function. The global -- Id is just the selector. Hmm. - ; return ((global', rhs) : fromOL spec_binds) } + ; return ((global', rhs) : fromOL spec_binds) } } ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) @@ -698,9 +700,9 @@ -- perhaps with the body of the lambda wrapped in some WpLets -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 - ; core_app <- dsHsWrapper spec_app + ; dsHsWrapper spec_app $ \core_app -> do - ; let ds_lhs = core_app (Var poly_id) + { let ds_lhs = core_app (Var poly_id) spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id -- , text "spec_co:" <+> ppr spec_co @@ -729,7 +731,7 @@ -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because -- makeCorePair overwrites the unfolding, which we have -- just created using specUnfolding - } } } + } } } } where is_local_id = isJust mb_poly_rhs poly_rhs | Just rhs <- mb_poly_rhs @@ -847,16 +849,7 @@ = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] | otherwise = case decompose fun2 args2 of - Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "rhs_fvs:" <+> ppr rhs_fvs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "lhs2:" <+> ppr lhs2 - -- , text "fun2:" <+> ppr fun2 - -- , text "args2:" <+> ppr args2 - -- ]) $ - Left (DsRuleLhsTooComplicated orig_lhs lhs2) + Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2) Just (fn_id, args) | not (null unbound) -> -- Check for things unbound on LHS @@ -928,9 +921,7 @@ split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) split_lets (Let (NonRec d r) body) - | isDictId d -- Catches dictionaries, yes, but also catches dictionary - -- /functions/ arising from solving a - -- quantified contraint (#24370) + | isDictId d = ((d,r):bs, body') where (bs, body') = split_lets body @@ -991,9 +982,9 @@ {-# RULES "myrule" foo C = 1 #-} After type checking the LHS becomes (foo alpha (C alpha)), where alpha -is an unbound meta-tyvar. The zonker in GHC.Tc.Utils.Zonk is careful not to +is an unbound meta-tyvar. The zonker in GHC.Tc.Zonk.Type is careful not to turn the free alpha into Any (as it usually does). Instead it turns it -into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk". +into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in "GHC.Tc.Zonk.Type". Now we must quantify over that 'a'. It's /really/ inconvenient to do that in the zonker, because the HsExpr data type is very large. But it's /easy/ @@ -1161,75 +1152,161 @@ This question arose when thinking about deep subsumption; see https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649). + +Note [Desugaring non-canonical evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the evidence is canonical, we desugar WpEvApp by simply passing +core_tm directly to k: + + k core_tm + +If the evidence is not canonical, we mark the application with nospec: + + nospec @(cls => a) k core_tm + +where nospec :: forall a. a -> a ensures that the typeclass specialiser +doesn't attempt to common up this evidence term with other evidence terms +of the same type (see Note [nospecId magic] in GHC.Types.Id.Make). + +See Note [Coherence and specialisation: overview] for why we shouldn't +specialise incoherent evidence. + +We can find out if a given evidence is canonical or not during the +desugaring of its WpLet wrapper: an evidence is non-canonical if its +own resolution was incoherent (see Note [Incoherent instances]), or +if its definition refers to other non-canonical evidence. dsEvBinds is +the convenient place to compute this, since it already needs to do +inter-evidence dependency analysis to generate well-scoped +bindings. We then record this specialisability information in the +dsl_unspecables field of DsM's local environment. + -} -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) -dsHsWrapper WpHole = return $ \e -> e -dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) -dsHsWrapper (WpEvLam ev) = return $ Lam ev -dsHsWrapper (WpTyLam tv) = return $ Lam tv -dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds - ; return (mkCoreLets bs) } -dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; return (w1 . w2) } -dsHsWrapper (WpFun c1 c2 (Scaled w t1)) -- See Note [Desugaring WpFun] - = do { x <- newSysLocalDs w t1 - ; w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - arg = w1 (Var x) - ; return (\e -> (Lam x (w2 (app e arg)))) } -dsHsWrapper (WpCast co) = assert (coercionRole co == Representational) $ - return $ \e -> mkCastDs e co -dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm - ; return (\e -> App e core_tm) } +dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a +dsHsWrapper WpHole k = k $ \e -> e +dsHsWrapper (WpTyApp ty) k = k $ \e -> App e (Type ty) +dsHsWrapper (WpEvLam ev) k = k $ Lam ev +dsHsWrapper (WpTyLam tv) k = k $ Lam tv +dsHsWrapper (WpLet ev_binds) k = do { dsTcEvBinds ev_binds $ \bs -> do + { k (mkCoreLets bs) } } +dsHsWrapper (WpCompose c1 c2) k = do { dsHsWrapper c1 $ \w1 -> do + { dsHsWrapper c2 $ \w2 -> do + { k (w1 . w2) } } } +dsHsWrapper (WpFun c1 c2 (Scaled w t1)) k -- See Note [Desugaring WpFun] + = do { x <- newSysLocalDs w t1 + ; dsHsWrapper c1 $ \w1 -> do + { dsHsWrapper c2 $ \w2 -> do + { let app f a = mkCoreAppDs (text "dsHsWrapper") f a + arg = w1 (Var x) + ; k (\e -> (Lam x (w2 (app e arg)))) } } } +dsHsWrapper (WpCast co) k = assert (coercionRole co == Representational) $ + k $ \e -> mkCastDs e co +dsHsWrapper (WpEvApp tm) k = do { core_tm <- dsEvTerm tm + ; unspecables <- getUnspecables + ; let vs = exprFreeVarsList core_tm + is_unspecable_var v = v `S.member` unspecables + is_specable = not $ any (is_unspecable_var) vs -- See Note [Desugaring non-canonical evidence] + ; k (\e -> app_ev is_specable e core_tm) } -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. -dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ - diagnosticDs DsMultiplicityCoercionsNotSupported - ; return $ \e -> e } +dsHsWrapper (WpMultCoercion co) k = do { unless (isReflexiveCo co) $ + diagnosticDs DsMultiplicityCoercionsNotSupported + ; k $ \e -> e } + +-- We are about to construct an evidence application `f dict`. If the dictionary is +-- non-specialisable, instead construct +-- nospec f dict +-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does. +app_ev :: Bool -> CoreExpr -> CoreExpr -> CoreExpr +app_ev is_specable k core_tm + | not is_specable + = Var nospecId `App` Type (exprType k) `App` k `App` core_tm + + | otherwise + = k `App` core_tm + +dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a +dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps) +dsHsWrappers [] k = k [] + -------------------------------------- -dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] -dsTcEvBinds_s [] = return [] -dsTcEvBinds_s (b:rest) = assert (null rest) $ -- Zonker ensures null - dsTcEvBinds b +dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a +dsTcEvBinds_s [] k = k [] +dsTcEvBinds_s (b:rest) k = assert (null rest) $ -- Zonker ensures null + dsTcEvBinds b k -dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] +dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this dsTcEvBinds (EvBinds bs) = dsEvBinds bs -dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs - = do { ds_bs <- mapBagM dsEvBind bs - ; return (mk_ev_binds ds_bs) } +-- * Desugars the ev_binds, sorts them into dependency order, and +-- passes the resulting [CoreBind] to thing_inside +-- * Extends the DsM (dsl_unspecable field) with specialisability information +-- for each binder in ev_binds, before invoking thing_inside +dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a +dsEvBinds ev_binds thing_inside + = do { ds_binds <- mapBagM dsEvBind ev_binds + ; let comps = sort_ev_binds ds_binds + ; go comps thing_inside } + where + go ::[SCC (Node EvVar (Canonical, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a + go (comp:comps) thing_inside + = do { unspecables <- getUnspecables + ; let (core_bind, new_unspecables) = ds_component unspecables comp + ; addUnspecables new_unspecables $ go comps $ \ core_binds -> thing_inside (core_bind:core_binds) } + go [] thing_inside = thing_inside [] -mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] + ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables) + where + ((v, rhs), (this_canonical, deps)) = unpack_node node + transitively_unspecable = not this_canonical || any is_unspecable deps + is_unspecable dep = dep `S.member` unspecables + new_unspecables + | transitively_unspecable = S.singleton v + | otherwise = mempty + ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables) + where + (pairs, direct_canonicity) = unzip $ map unpack_node nodes + + is_unspecable_remote dep = dep `S.member` unspecables + transitively_unspecable = or [ not this_canonical || any is_unspecable_remote deps | (this_canonical, deps) <- direct_canonicity ] + -- Bindings from a given SCC are transitively specialisable if + -- all are specialisable and all their remote dependencies are + -- also specialisable; see Note [Desugaring non-canonical evidence] + + new_unspecables + | transitively_unspecable = S.fromList [ v | (v, _) <- pairs] + | otherwise = mempty + + unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps } = ((v, rhs), (canonical, deps)) + +sort_ev_binds :: Bag (Id, Canonical, CoreExpr) -> [SCC (Node EvVar (Canonical, CoreExpr))] -- We do SCC analysis of the evidence bindings, /after/ desugaring -- them. This is convenient: it means we can use the GHC.Core -- free-variable functions rather than having to do accurate free vars -- for EvTerm. -mk_ev_binds ds_binds - = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) +sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges where - edges :: [ Node EvVar (EvVar,CoreExpr) ] + edges :: [ Node EvVar (Canonical, CoreExpr) ] edges = foldr ((:) . mk_node) [] ds_binds - mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) - mk_node b@(var, rhs) - = DigraphNode { node_payload = b + mk_node :: (Id, Canonical, CoreExpr) -> Node EvVar (Canonical, CoreExpr) + mk_node (var, canonical, rhs) + = DigraphNode { node_payload = (canonical, rhs) , node_key = var , node_dependencies = nonDetEltsUniqSet $ exprFreeVars rhs `unionVarSet` coVarsOfType (varType var) } - -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices + -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq -- is still deterministic even if the edges are in nondeterministic order -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. - ds_scc (AcyclicSCC (v,r)) = NonRec v r - ds_scc (CyclicSCC prs) = Rec prs - -dsEvBind :: EvBind -> DsM (Id, CoreExpr) -dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) +dsEvBind :: EvBind -> DsM (Id, Canonical, CoreExpr) +dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do + e <- dsEvTerm r + let canonical = case info of + EvBindGiven{} -> True + EvBindWanted{ ebi_canonical = canonical } -> canonical + return (v, canonical, e) {-********************************************************************** @@ -1243,10 +1320,10 @@ dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev dsEvTerm (EvFun { et_tvs = tvs, et_given = given , et_binds = ev_binds, et_body = wanted_id }) - = do { ds_ev_binds <- dsTcEvBinds ev_binds - ; return $ (mkLams (tvs ++ given) $ + = do { dsTcEvBinds ev_binds $ \ds_ev_binds -> do + { return $ (mkLams (tvs ++ given) $ mkCoreLets ds_ev_binds $ - Var wanted_id) } + Var wanted_id) } } {-********************************************************************** @@ -1333,7 +1410,7 @@ } ds_ev_typeable ty (EvTypeableTyLit ev) - = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact + = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class do { fun <- dsLookupGlobalId tr_fun ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) } diff --git a/compiler/GHC/HsToCore/Binds.hs-boot b/compiler/GHC/HsToCore/Binds.hs-boot --- a/compiler/GHC/HsToCore/Binds.hs-boot +++ b/compiler/GHC/HsToCore/Binds.hs-boot @@ -3,4 +3,4 @@ import GHC.Core ( CoreExpr ) import GHC.Tc.Types.Evidence (HsWrapper) -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) +dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a diff --git a/compiler/GHC/HsToCore/Breakpoints.hs b/compiler/GHC/HsToCore/Breakpoints.hs --- a/compiler/GHC/HsToCore/Breakpoints.hs +++ b/compiler/GHC/HsToCore/Breakpoints.hs @@ -27,18 +27,16 @@ breakArray <- GHCi.newBreakArray interp count ccs <- mkCCSArray interp mod count entries - mod_ptr <- GHCi.newModuleName interp (moduleName mod) let locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] return $ emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - , modBreaks_module = mod_ptr + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs } mkCCSArray 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 @@ -44,7 +44,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty ((:|))) import GHC.Unit.Module.Imported -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.TypeEnv import GHC.Types.Id import GHC.Types.Unique.Map @@ -192,7 +192,13 @@ Just loc -> L loc (DsiExports [avail]) -- FIXME: This is just a workaround that we use when handling e.g. -- associated data families like in the html-test Instances.hs. - Nothing -> noLoc (DsiExports [avail]) + Nothing -> noLoc (DsiExports []) + + -- This causes the associated data family to be incorrectly documented + -- separately from its class: + -- Nothing -> noLoc (DsiExports [avail]) + + -- This panics on the associated data family: -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for" -- (ppr avail) 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 @@ -28,12 +28,13 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad -import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) +import GHC.HsToCore.Pmc import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote +import GHC.HsToCore.Ticks (stripTicksTopHsExpr) import GHC.Hs -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -66,7 +67,6 @@ import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad -import GHC.HsToCore.Ticks (stripTicksTopHsExpr) {- ************************************************************************ @@ -92,11 +92,11 @@ ------------------------- dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ev_binds ip_binds) body - = do { ds_binds <- dsTcEvBinds ev_binds - ; let inner = mkCoreLets ds_binds body + = do { dsTcEvBinds ev_binds $ \ ds_binds -> do + { let inner = mkCoreLets ds_binds body -- The dict bindings may not be in -- dependency order; hence Rec - ; foldrM ds_ip_bind inner ip_binds } + ; foldrM ds_ip_bind inner ip_binds } } where ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr ds_ip_bind (L _ (IPBind n _ e)) body @@ -182,8 +182,8 @@ bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) body1 lbinds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (mkCoreLets ds_binds body2) } + ; dsTcEvBinds_s ev_binds $ \ ds_binds -> do + { return (mkCoreLets ds_binds body2) } } dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches @@ -193,11 +193,11 @@ -- so must be simply unboxed = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches ; massert (null args) -- Functions aren't unlifted - ; core_wrap <- dsHsWrapper co_fn -- Can be non-identity (#21516) - ; let rhs' = core_wrap (mkOptTickBox tick rhs) - ; return (bindNonRec fun rhs' body) } + ; dsHsWrapper co_fn $ \core_wrap -> do -- Can be non-identity (#21516) + { let rhs' = core_wrap (mkOptTickBox tick rhs) + ; return (bindNonRec fun rhs' body) } } -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss +dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss , pat_ext = (ty, _) }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body @@ -223,19 +223,11 @@ ************************************************************************ -} - --- | Replace the body of the function with this block to test the hsExprType --- function in GHC.Tc.Utils.Zonk: --- putSrcSpanDs loc $ do --- { core_expr <- dsExpr e --- ; massertPpr (exprType core_expr `eqType` hsExprType e) --- (ppr e <+> dcolon <+> ppr (hsExprType e) $$ --- ppr core_expr <+> dcolon <+> ppr (exprType core_expr)) --- ; return core_expr } +-- | Desugar a located typechecked expression. dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (L loc e) = - putSrcSpanDsA loc $ dsExpr e +dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e +-- | Desugar a typechecked expression. dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsVar _ (L _ id)) = dsHsVar id dsExpr (HsRecSel _ (FieldOcc id _)) = dsHsVar id @@ -373,9 +365,9 @@ dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr -dsExpr (HsCase _ discrim matches) +dsExpr (HsCase ctxt discrim matches) = do { core_discrim <- dsLExpr discrim - ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches + ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches ; return (bindNonRec discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group @@ -550,16 +542,16 @@ , syn_res_wrap = res_wrap }) arg_exprs = do { fun <- dsExpr expr - ; core_arg_wraps <- mapM dsHsWrapper arg_wraps - ; core_res_wrap <- dsHsWrapper res_wrap - ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs - ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } + ; dsHsWrappers arg_wraps $ \core_arg_wraps -> do + { dsHsWrapper res_wrap $ \core_res_wrap -> do + { let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs + ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } } } dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel = [hfbRHS fld | L _ fld <- rbinds - , sel == idName (hsRecFieldId fld) ] + , sel == idName (hsRecFieldId fld) ] {- %-------------------------------------------------------------------- @@ -691,11 +683,13 @@ ; dsLocalBinds binds rest } go _ (BindStmt xbs pat rhs) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat + = do { var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat + ; rhs' <- dsLExpr rhs ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat - (xbstc_boundResultType xbs) (cantFailMatchResult body) + (xbstc_boundResultType xbs) (MR_Infallible $ goL stmts) + -- NB: "goL stmts" needs to happen inside matchSinglePatVar, and not + -- before it, so that long-distance information is properly threaded. + -- See Note [Long-distance information in do notation]. ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } @@ -755,11 +749,12 @@ later_pats = rec_tup_pats rets = map noLocA rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] + match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated SkipPmc) mfix_arg = noLocA $ HsLam noExtField (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated + , mg_ext = match_group }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLocA $ HsDo body_ty @@ -773,7 +768,52 @@ go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" -{- +{- Note [Long-distance information in do notation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T21360: + + data Foo = A Int | B + + swooble :: Foo -> Maybe Foo + swooble foo = do + bar@A{} <- Just foo + return $ case bar of { A _ -> A 9 } + +The pattern-match checker **should not** complain that the case statement +is incomplete, because we know that 'bar' is headed by the constructor 'A', +due to the pattern match in the line above. However, we need to ensure that we +propagate this long-distance information; failing to do so lead to #21360. + +To do this, we use "matchSinglePatVar" to handle the first pattern match + + bar@A{} <- Just foo + +"matchSinglePatVar" then threads through the long-distance information to the +desugaring of the remaining statements by using updPmNablasMatchResult. +This avoids any spurious pattern-match warnings when handling the case +statement on the last line. + +Other places that requires from the same treatment: + + - monad comprehensions, e.g. + + blorble :: Foo -> Maybe Foo + blorble foo = [ case bar of { A _ -> A 9 } | bar@A{} <- Just foo ] + + See GHC.HsToCore.ListComp.dsMcBindStmt. Also tested in T21360. + + - guards, e.g. + + giddy :: Maybe Char -> Char + giddy x + | y@(Just _) <- x + , let z = case y of { Just w -> w } + = z + + We don't want any inexhaustive pattern match warnings for the case statement, + because we already know 'y' is of the form "Just ...". + See test case T21360b. + ************************************************************************ * * Desugaring Variables @@ -872,15 +912,15 @@ = go (wrap <.> WpTyApp ty) hs_e go wrap (HsVar _ (L _ var)) - = do { wrap' <- dsHsWrapper wrap - ; let expr = wrap' (varToCoreExpr var) + = do { dsHsWrapper wrap $ \wrap' -> do + { let expr = wrap' (varToCoreExpr var) ty = exprType expr ; dflags <- getDynFlags ; warnAboutIdentities dflags var ty - ; return expr } + ; return expr } } go wrap hs_e - = do { wrap' <- dsHsWrapper wrap - ; addTyCs FromSource (hsWrapDictBinders wrap) $ + = do { dsHsWrapper wrap $ \wrap' -> do + { addTyCs FromSource (hsWrapDictBinders wrap) $ do { e <- dsExpr hs_e - ; return (wrap' e) } } + ; return (wrap' e) } } } diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -42,7 +42,7 @@ import GHC.Unit.Module -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Cmm.Expr @@ -401,11 +401,17 @@ Int -- total size of arguments ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = - ( header_bits + = ( header_bits , CStub body [] [] , type_string, - aug_arg_size + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM ) where platform = targetPlatform dflags @@ -444,19 +450,6 @@ | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info | otherwise = arg_info - aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM - -- AK: This seems just wrong, the code here uses widthInBytes, but when - -- we pass args on the haskell stack we always extend to multiples of 8 - -- to my knowledge. Not sure if it matters though so I won't touch this - -- for now. - stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, typeCmmType platform (mkStablePtrPrimTy alphaTy)) @@ -561,7 +554,7 @@ , ppUnless res_hty_is_unit $ if libffi then char '*' <> parens (ffi_cResType <> char '*') <> - text "resp = " <> parens ffi_cResType <> text "cret;" + text "resp = cret;" else text "return cret;" , rbrace ] @@ -612,11 +605,8 @@ -> [(SDoc, SDoc, Type, CmmType)] go 6 args = ret_addr_arg platform : args go n (arg@(_,_,_,rep):args) - -- Int type fitting into int register - | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep) - = arg : go (n+1) args - | otherwise - = arg : go n args + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args go _ [] = [] in go 0 args _ -> 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 @@ -42,7 +42,7 @@ import GHC.Types.Basic import GHC.Types.Literal import GHC.Builtin.Names -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain 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 @@ -33,7 +33,7 @@ import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Platform import GHC.Data.OrdList import GHC.Driver.Hooks diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs --- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs +++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs @@ -50,7 +50,7 @@ import GHC.JS.Ppr -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Builtin.Types @@ -156,7 +156,7 @@ header_bits = maybe mempty idTag maybe_target idTag i = let (tag, u) = unpkUnique (getUnique i) - in CHeader (char tag <> word64 u) + in CHeader (char tag <> int u) fun_args | null arg_info = empty -- text "void" @@ -177,14 +177,14 @@ text "h$foreignExport" <> parens ( ftext c_nm <> comma <> - strlit (unitIdString (moduleUnitId m)) <> comma <> - strlit (moduleNameString (moduleName m)) <> comma <> - strlit (unpackFS c_nm) <> comma <> - strlit type_string + strlit (unitIdFS (moduleUnitId m)) <> comma <> + strlit (moduleNameFS (moduleName m)) <> comma <> + strlit c_nm <> comma <> + strlit (mkFastString type_string) ) <> semi _ -> empty - strlit xs = docToSDoc (pprStringLit (mkFastString xs)) + strlit xs = pprStringLit xs -- the target which will form the root of what we ask rts_evalIO to run the_cfun @@ -382,16 +382,16 @@ mkHObj :: Type -> SDoc -mkHObj t = text "h$rts_mk" <> text (showFFIType t) +mkHObj t = text "h$rts_mk" <> showFFIType t unpackHObj :: Type -> SDoc -unpackHObj t = text "h$rts_get" <> text (showFFIType t) +unpackHObj t = text "h$rts_get" <> showFFIType t showStgType :: Type -> SDoc -showStgType t = text "Hs" <> text (showFFIType t) +showStgType t = text "Hs" <> showFFIType t -showFFIType :: Type -> String -showFFIType t = getOccString (getName (typeTyCon t)) +showFFIType :: Type -> SDoc +showFFIType t = ftext (occNameFS (getOccName (typeTyCon t))) typeTyCon :: Type -> TyCon typeTyCon ty @@ -639,7 +639,7 @@ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do -- result_id <- newSysLocalDs boolTy ccall_uniq <- newUnique - let forceBool e = mkJsCall ccall_uniq "((x) => { return !(!x); })" [e] boolTy + let forceBool e = mkJsCall ccall_uniq (fsLit "((x) => { return !(!x); })") [e] boolTy return (Just intPrimTy, \e -> forceBool e) @@ -674,10 +674,10 @@ maybe_tc_app = splitTyConApp_maybe result_ty -- low-level primitive JavaScript call: -mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr +mkJsCall :: Unique -> FastString -> [CoreExpr] -> Type -> CoreExpr mkJsCall u tgt args t = mkFCall u ccall args t where ccall = CCall $ CCallSpec - (StaticTarget NoSourceText (mkFastString tgt) (Just primUnit) True) + (StaticTarget NoSourceText tgt (Just primUnit) True) JavaScriptCallConv PlayRisky 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 @@ -55,7 +55,7 @@ -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. -dsGRHSs :: HsMatchContext GhcRn +dsGRHSs :: HsMatchContext GhcTc -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs -> Type -- ^ Type of RHS -> NonEmpty Nablas -- ^ Refined pattern match checking @@ -76,10 +76,10 @@ -- NB: nested dsLet inside matchResult ; return match_result2 } -dsGRHS :: HsMatchContext GhcRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) +dsGRHS :: HsMatchContext GhcTc -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs)) - = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty + = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty {- ************************************************************************ @@ -90,7 +90,7 @@ -} matchGuards :: [GuardStmt GhcTc] -- Guard - -> HsStmtContext GhcRn -- Context + -> HsMatchContext GhcTc -- Context -> Nablas -- The RHS's covered set for PmCheck -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard @@ -130,15 +130,16 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do let upat = unLoc pat match_var <- selectMatchVar ManyTy upat - -- We only allow unrestricted patterns in guard, hence the `Many` + -- We only allow unrestricted patterns in guards, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. match_result <- matchGuards stmts ctx nablas rhs rhs_ty core_rhs <- dsLExpr bind_rhs - match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx) - pat rhs_ty match_result - pure $ bindNonRec match_var core_rhs <$> match_result' + match_result' <- + matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx) + pat rhs_ty match_result + return $ bindNonRec match_var core_rhs <$> match_result' matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt" matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt" 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 @@ -23,7 +23,7 @@ import GHC.HsToCore.Monad -- the monadery used in the desugarer import GHC.HsToCore.Utils -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type @@ -444,15 +444,13 @@ ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty - ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) tupled_concat_expression = mkBigCoreTup concat_expressions - folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs) - folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case + ; folder_body_inner_case <- mkBigTupleCase xss tupled_concat_expression (Var axs) + ; folder_body_outer_case <- mkBigTupleCase xs folder_body_inner_case (Var ax) + ; let folder_body = mkLams [ax, axs] folder_body_outer_case ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } @@ -546,9 +544,8 @@ ; body <- dsMcStmts stmts_rest ; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys - ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkBigTupleCase us to_bndrs body tup_n_expr' + ; body' <- mkBigTupleCase to_bndrs body tup_n_expr' ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } @@ -584,17 +581,17 @@ = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } -dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) - +dsMcStmt stmt@(ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) +dsMcStmt stmt@(RecStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr -- (matchTuple [a,b,c] body) -- returns the Core term -- \x. case x of (a,b,c) -> body matchTuple ids body - = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) } + = do { tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) + ; tup_case <- mkBigTupleCase ids body (Var tup_id) + ; return (Lam tup_id tup_case) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` @@ -606,10 +603,12 @@ -> [ExprLStmt GhcTc] -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts - = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL ManyTy pat + = do { var <- selectSimpleMatchVarL ManyTy pat ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat - res1_ty (cantFailMatchResult body) + res1_ty (MR_Infallible $ dsMcStmts stmts) + -- NB: dsMcStmts needs to happen inside matchSinglePatVar, and not + -- before it, so that long-distance information is properly threaded. + -- See Note [Long-distance information in do notation] in GHC.HsToCore.Expr. ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } 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 @@ -1,4 +1,5 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternSynonyms #-} @@ -28,9 +29,9 @@ import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated ) +import GHC.Types.Basic ( Origin(..), isGenerated, requiresPMC ) import GHC.Types.SourceText -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Hs import GHC.Hs.Syn.Type import GHC.Tc.Types.Evidence @@ -72,7 +73,7 @@ import GHC.Types.Unique import GHC.Types.Unique.DFM -import Control.Monad ( zipWithM, unless, when ) +import Control.Monad ( zipWithM, unless ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map @@ -285,9 +286,9 @@ ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getCoPat <$> eqns - ; core_wrap <- dsHsWrapper co - ; let bind = NonRec var' (core_wrap (Var var)) - ; return (mkCoLetMatchResult bind match_result) } + ; dsHsWrapper co $ \core_wrap -> do + { let bind = NonRec var' (core_wrap (Var var)) + ; return (mkCoLetMatchResult bind match_result) } } matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Apply the view function to the match variable and then match that @@ -736,7 +737,7 @@ -- p2 q2 -> ... matchWrapper - :: HsMatchContext GhcRn -- ^ For shadowing warning messages + :: HsMatchContext GhcTc -- ^ For shadowing warning messages -> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s) -- see Note [matchWrapper scrutinees] -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared @@ -798,7 +799,7 @@ ; eqns_info <- zipWithM mk_eqn_info matches matches_nablas - ; result_expr <- discard_warnings_if_generated origin $ + ; result_expr <- discard_warnings_if_skip_pmc origin $ matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } @@ -818,10 +819,10 @@ , eqn_orig = FromSource , eqn_rhs = match_result } } - discard_warnings_if_generated orig = - if isGenerated orig - then discardWarningsDs - else id + discard_warnings_if_skip_pmc orig = + if requiresPMC orig + then id + else discardWarningsDs initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)] initNablasMatches ldi_nablas ms @@ -880,7 +881,7 @@ on the user-written case statement). -} -matchEquations :: HsMatchContext GhcRn +matchEquations :: HsMatchContext GhcTc -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty @@ -894,7 +895,7 @@ -- situation where we want to match a single expression against a single -- pattern. It returns an expression. matchSimply :: CoreExpr -- ^ Scrutinee - -> HsMatchContext GhcRn -- ^ Match kind + -> HsMatchContext GhcTc -- ^ Match kind -> LPat GhcTc -- ^ Pattern it should match -> CoreExpr -- ^ Return this if it matches -> CoreExpr -- ^ Return this if it doesn't @@ -916,7 +917,7 @@ match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc +matchSinglePat :: CoreExpr -> HsMatchContext GhcTc -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar @@ -942,22 +943,36 @@ matchSinglePatVar :: Id -- See Note [Match Ids] -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to - -> HsMatchContext GhcRn -> LPat GhcTc + -> HsMatchContext GhcTc -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var mb_scrut ctx pat ty match_result = assertPpr (isInternalName (idName var)) (ppr var) $ do { dflags <- getDynFlags ; locn <- getSrcSpanDs - -- Pattern match check warnings - ; when (isMatchContextPmChecked dflags FromSource ctx) $ - addCoreScrutTmCs (maybeToList mb_scrut) [var] $ - pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + -- Pattern match check warnings. + -- See Note [Long-distance information in matchWrapper] and + -- Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + ; ldi_nablas <- + if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat + then addCoreScrutTmCs (maybeToList mb_scrut) [var] $ + pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + else getLdiNablas ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] , eqn_orig = FromSource - , eqn_rhs = match_result } + , eqn_rhs = + updPmNablasMatchResult ldi_nablas match_result } + -- See Note [Long-distance information in do notation] + -- in GHC.HsToCore.Expr. + ; match [var] ty [eqn_info] } +updPmNablasMatchResult :: Nablas -> MatchResult r -> MatchResult r +updPmNablasMatchResult nablas = \case + MR_Infallible body_fn -> MR_Infallible $ + updPmNablas nablas body_fn + MR_Fallible body_fn -> MR_Fallible $ \fail -> + updPmNablas nablas $ body_fn fail {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -6,7 +6,7 @@ import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr ) import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) -import GHC.Hs.Extension ( GhcTc, GhcRn ) +import GHC.Hs.Extension ( GhcTc ) match :: [Id] -> Type @@ -14,14 +14,14 @@ -> DsM (MatchResult CoreExpr) matchWrapper - :: HsMatchContext GhcRn + :: HsMatchContext GhcTc -> Maybe [LHsExpr GhcTc] -> MatchGroup GhcTc (LHsExpr GhcTc) -> DsM ([Id], CoreExpr) matchSimply :: CoreExpr - -> HsMatchContext GhcRn + -> HsMatchContext GhcTc -> LPat GhcTc -> CoreExpr -> CoreExpr @@ -30,7 +30,7 @@ matchSinglePatVar :: Id -> Maybe CoreExpr - -> HsMatchContext GhcRn + -> HsMatchContext GhcTc -> LPat GhcTc -> Type -> MatchResult CoreExpr 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 @@ -20,7 +20,7 @@ import GHC.Hs import GHC.HsToCore.Binds import GHC.Core.ConLike -import GHC.Types.Basic ( Origin(..) ) +import GHC.Types.Basic import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity import GHC.HsToCore.Monad @@ -163,13 +163,13 @@ } } : pats })) - = do ds_bind <- dsTcEvBinds bind - return ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets ds_bind - , eqn { eqn_orig = Generated - , eqn_pats = conArgPats val_arg_tys args ++ pats } - ) + = do dsTcEvBinds bind $ \ds_bind -> + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_orig = Generated SkipPmc + , eqn_pats = conArgPats val_arg_tys args ++ pats } + ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys -- The 'val_arg_tys' are taken from the data type definition, they 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 @@ -36,7 +36,7 @@ import GHC.Hs -import GHC.Tc.Utils.Zonk ( shortCutLit ) +import GHC.Tc.Utils.TcMType ( shortCutLit ) import GHC.Tc.Utils.TcType import GHC.Core @@ -58,13 +58,12 @@ import GHC.Types.Id import GHC.Types.SourceText -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Unique (sameUnique) import GHC.Data.FastString @@ -107,7 +106,13 @@ HsCharPrim _ c -> return (Lit (LitChar c)) HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) + HsInt8Prim _ i -> return (Lit (mkLitInt8Wrap i)) + HsInt16Prim _ i -> return (Lit (mkLitInt16Wrap i)) + HsInt32Prim _ i -> return (Lit (mkLitInt32Wrap i)) HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i)) + HsWord8Prim _ w -> return (Lit (mkLitWord8Wrap w)) + HsWord16Prim _ w -> return (Lit (mkLitWord16Wrap w)) + HsWord32Prim _ w -> return (Lit (mkLitWord32Wrap w)) HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w)) -- This can be slow for very large literals. See Note [FractionalLit representation] @@ -314,29 +319,29 @@ , Just (i, tc) <- lit = if -- These only show up via the 'HsOverLit' route - | sameUnique tc intTyConName -> check i tc minInt maxInt - | sameUnique tc wordTyConName -> check i tc minWord maxWord - | sameUnique tc int8TyConName -> check i tc (min' @Int8) (max' @Int8) - | sameUnique tc int16TyConName -> check i tc (min' @Int16) (max' @Int16) - | sameUnique tc int32TyConName -> check i tc (min' @Int32) (max' @Int32) - | sameUnique tc int64TyConName -> check i tc (min' @Int64) (max' @Int64) - | sameUnique tc word8TyConName -> check i tc (min' @Word8) (max' @Word8) - | sameUnique tc word16TyConName -> check i tc (min' @Word16) (max' @Word16) - | sameUnique tc word32TyConName -> check i tc (min' @Word32) (max' @Word32) - | sameUnique tc word64TyConName -> check i tc (min' @Word64) (max' @Word64) - | sameUnique tc naturalTyConName -> checkPositive i tc + | tc == intTyConName -> check i tc minInt maxInt + | tc == wordTyConName -> check i tc minWord maxWord + | tc == int8TyConName -> check i tc (min' @Int8) (max' @Int8) + | tc == int16TyConName -> check i tc (min' @Int16) (max' @Int16) + | tc == int32TyConName -> check i tc (min' @Int32) (max' @Int32) + | tc == int64TyConName -> check i tc (min' @Int64) (max' @Int64) + | tc == word8TyConName -> check i tc (min' @Word8) (max' @Word8) + | tc == word16TyConName -> check i tc (min' @Word16) (max' @Word16) + | tc == word32TyConName -> check i tc (min' @Word32) (max' @Word32) + | tc == word64TyConName -> check i tc (min' @Word64) (max' @Word64) + | tc == naturalTyConName -> checkPositive i tc -- These only show up via the 'HsLit' route - | sameUnique tc intPrimTyConName -> check i tc minInt maxInt - | sameUnique tc wordPrimTyConName -> check i tc minWord maxWord - | sameUnique tc int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) - | sameUnique tc int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) - | sameUnique tc int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) - | sameUnique tc int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) - | sameUnique tc word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) - | sameUnique tc word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) - | sameUnique tc word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) - | sameUnique tc word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) + | tc == intPrimTyConName -> check i tc minInt maxInt + | tc == wordPrimTyConName -> check i tc minWord maxWord + | tc == int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) + | tc == int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) + | tc == int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) + | tc == int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) + | tc == word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) + | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) + | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) + | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) | otherwise -> return () @@ -393,22 +398,22 @@ platform <- targetPlatform <$> getDynFlags -- Be careful to use target Int/Word sizes! cf #17336 - if | sameUnique tc intTyConName -> case platformWordSize platform of - PW4 -> check @Int32 - PW8 -> check @Int64 - | sameUnique tc wordTyConName -> case platformWordSize platform of - PW4 -> check @Word32 - PW8 -> check @Word64 - | sameUnique tc int8TyConName -> check @Int8 - | sameUnique tc int16TyConName -> check @Int16 - | sameUnique tc int32TyConName -> check @Int32 - | sameUnique tc int64TyConName -> check @Int64 - | sameUnique tc word8TyConName -> check @Word8 - | sameUnique tc word16TyConName -> check @Word16 - | sameUnique tc word32TyConName -> check @Word32 - | sameUnique tc word64TyConName -> check @Word64 - | sameUnique tc integerTyConName -> check @Integer - | sameUnique tc naturalTyConName -> check @Integer + if | tc == intTyConName -> case platformWordSize platform of + PW4 -> check @Int32 + PW8 -> check @Int64 + | tc == wordTyConName -> case platformWordSize platform of + PW4 -> check @Word32 + PW8 -> check @Word64 + | tc == int8TyConName -> check @Int8 + | tc == int16TyConName -> check @Int16 + | tc == int32TyConName -> check @Int32 + | tc == int64TyConName -> check @Int64 + | tc == word8TyConName -> check @Word8 + | tc == word16TyConName -> check @Word16 + | tc == word32TyConName -> check @Word32 + | tc == word64TyConName -> check @Word64 + | tc == integerTyConName -> check @Integer + | tc == naturalTyConName -> check @Integer -- We use 'Integer' because otherwise a negative 'Natural' literal -- could cause a compile time crash (instead of a runtime one). -- See the T10930b test case for an example of where this matters. @@ -456,11 +461,24 @@ getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy) getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy) getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy) +getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy) +getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy) +getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy) getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy) +getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy) +getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy) +getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy) getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) -getSimpleIntegralLit _ = Nothing +getSimpleIntegralLit HsChar{} = Nothing +getSimpleIntegralLit HsCharPrim{} = Nothing +getSimpleIntegralLit HsString{} = Nothing +getSimpleIntegralLit HsStringPrim{} = Nothing +getSimpleIntegralLit HsRat{} = Nothing +getSimpleIntegralLit HsFloatPrim{} = Nothing +getSimpleIntegralLit HsDoublePrim{} = Nothing + -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char getLHsCharLit (L _ (HsPar _ _ e _)) = getLHsCharLit e @@ -639,7 +657,13 @@ -- HsLit does not. hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey _ (HsInt8Prim _ i) = mkLitInt8Wrap i +hsLitKey _ (HsInt16Prim _ i) = mkLitInt16Wrap i +hsLitKey _ (HsInt32Prim _ i) = mkLitInt32Wrap i hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i +hsLitKey _ (HsWord8Prim _ w) = mkLitWord8Wrap w +hsLitKey _ (HsWord16Prim _ w) = mkLitWord16Wrap w +hsLitKey _ (HsWord32Prim _ w) = mkLitWord32Wrap w hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w hsLitKey _ (HsCharPrim _ c) = mkLitChar c -- This following two can be slow. See Note [FractionalLit representation] diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -36,6 +36,9 @@ -- Getting and setting pattern match oracle states getPmNablas, updPmNablas, + -- Tracking evidence variable coherence + addUnspecables, getUnspecables, + -- Get COMPLETE sets of a TyCon dsGetCompleteMatches, @@ -54,7 +57,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic @@ -91,6 +94,7 @@ import GHC.Types.Basic ( Origin ) import GHC.Types.SourceFile import GHC.Types.Id +import GHC.Types.Var (EvId) import GHC.Types.SrcLoc import GHC.Types.TypeEnv import GHC.Types.Unique.Supply @@ -109,6 +113,7 @@ import Data.IORef import GHC.Driver.Env.KnotVars +import qualified Data.Set as S {- ************************************************************************ @@ -119,7 +124,7 @@ -} data DsMatchContext - = DsMatchContext (HsMatchContext GhcRn) SrcSpan + = DsMatchContext (HsMatchContext GhcTc) SrcSpan deriving () instance Outputable DsMatchContext where @@ -349,9 +354,10 @@ , ds_cc_st = cc_st_var , ds_next_wrapper_num = next_wrapper_num } - lcl_env = DsLclEnv { dsl_meta = emptyNameEnv - , dsl_loc = real_span - , dsl_nablas = initNablas + lcl_env = DsLclEnv { dsl_meta = emptyNameEnv + , dsl_loc = real_span + , dsl_nablas = initNablas + , dsl_unspecables = mempty } in (gbl_env, lcl_env) @@ -406,6 +412,12 @@ -- See 'dsl_nablas'. updPmNablas :: Nablas -> DsM a -> DsM a updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) + +addUnspecables :: S.Set EvId -> DsM a -> DsM a +addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env }) + +getUnspecables :: DsM (S.Set EvId) +getUnspecables = dsl_unspecables <$> getLclEnv getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -36,7 +36,7 @@ module GHC.HsToCore.Pmc ( -- Checking and printing pmcPatBind, pmcMatches, pmcGRHSs, - isMatchContextPmChecked, + isMatchContextPmChecked, isMatchContextPmChecked_SinglePat, -- See Note [Long-distance information] addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas @@ -52,7 +52,7 @@ import GHC.HsToCore.Pmc.Solver import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc @@ -98,21 +98,36 @@ noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings) -- | Check a pattern binding (let, where) for exhaustiveness. -pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM () --- See Note [pmcPatBind only checks PatBindRhs] -pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do - !missing <- getLdiNablas - pat_bind <- noCheckDs $ desugarPatBind loc var p - tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) - result <- unCA (checkPatBind pat_bind) missing - tracePm "}: " (ppr (cr_uncov result)) - formatReportWarnings ReportPatBind ctxt [var] result -pmcPatBind _ _ _ = pure () +pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM Nablas +pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p + = mb_discard_warnings $ do + !missing <- getLdiNablas + pat_bind <- noCheckDs $ desugarPatBind loc var p + tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) + result <- unCA (checkPatBind pat_bind) missing + let ldi = ldiGRHS $ ( \ pb -> case pb of PmPatBind grhs -> grhs) $ cr_ret result + tracePm "pmcPatBind }: " $ + vcat [ text "cr_uncov:" <+> ppr (cr_uncov result) + , text "ldi:" <+> ppr ldi ] + formatReportWarnings ReportPatBind ctxt [var] result + return ldi + where + -- See Note [pmcPatBind doesn't warn on pattern guards] + mb_discard_warnings + = if want_pmc match_ctxt + then id + else discardWarningsDs + want_pmc PatBindRhs = True + want_pmc (StmtCtxt stmt_ctxt) = + case stmt_ctxt of + PatGuard {} -> False + _ -> True + want_pmc _ = False -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs. pmcGRHSs - :: HsMatchContext GhcRn -- ^ Match context, for warning messages + :: HsMatchContext GhcTc -- ^ Match context, for warning messages -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check -> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long -- distance info @@ -178,22 +193,29 @@ {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result return (NE.toList (ldiMatchGroup (cr_ret result))) -{- Note [pmcPatBind only checks PatBindRhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@pmcPatBind@'s sole purpose is to check vanilla pattern bindings, like +{- Note [pmcPatBind doesn't warn on pattern guards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@pmcPatBind@'s main purpose is to check vanilla pattern bindings, like @x :: Int; Just x = e@, which is in a @PatBindRhs@ context. But its caller is also called for individual pattern guards in a @StmtCtxt@. For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will -go through this function. It makes no sense to do coverage checking there: +go through this function. It makes no sense to report pattern match warnings +for these pattern guards: + * Pattern guards may well fail. Fall-through is not an unrecoverable panic, but rather behavior the programmer expects, so inexhaustivity should not be reported. + * Redundancy is already reported for the whole GRHS via one of the other - exported coverage checking functions. Also reporting individual redundant + exported coverage checking functions. Also, reporting individual redundant guards is... redundant. See #17646. -Note that we can't just omit checking of @StmtCtxt@ altogether (by adjusting -'isMatchContextPmChecked'), because that affects the other checking functions, -too. + +However, we should not skip pattern-match checking altogether, as it may reveal +important long-distance information. One example is described in +Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + +Instead, we simply discard warnings when in pattern-guards, by using the function +discardWarningsDs. -} -- diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs --- a/compiler/GHC/HsToCore/Pmc/Check.hs +++ b/compiler/GHC/HsToCore/Pmc/Check.hs @@ -29,7 +29,7 @@ import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Solver -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Outputable import GHC.Tc.Utils.TcType (evVarPred) import GHC.Data.OrdList diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -21,9 +21,9 @@ import GHC.Core (Expr(Var,App)) import GHC.Data.FastString (unpackFS, lengthFS) import GHC.Data.Bag (bagToList) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Hs -import GHC.Tc.Utils.Zonk (shortCutLit) +import GHC.Tc.Utils.TcMType (shortCutLit) import GHC.Types.Id import GHC.Core.ConLike import GHC.Types.Name @@ -48,7 +48,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Monad (concatMapM) import GHC.Types.SourceText (FractionalLit(..)) -import Control.Monad (zipWithM) +import Control.Monad (zipWithM, replicateM) import Data.List (elemIndex) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE @@ -92,7 +92,7 @@ -- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler -- here. See Note [Representation of Strings in TmState] in -- GHC.HsToCore.Pmc.Solver - vars <- traverse mkPmId (take (lengthFS s) (repeat charTy)) + vars <- replicateM (lengthFS s) (mkPmId charTy) let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c)) char_grdss <- zipWithM mk_char_lit vars (unpackFS s) mkListGrds x (zip vars char_grdss) @@ -154,8 +154,8 @@ | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p | otherwise -> do (y, grds) <- desugarPatV p - wrap_rhs_y <- dsHsWrapper wrapper - pure (PmLet y (wrap_rhs_y (Var x)) : grds) + dsHsWrapper wrapper $ \wrap_rhs_y -> + pure (PmLet y (wrap_rhs_y (Var x)) : grds) -- (n + k) ===> let b = x >= k, True <- b, let n = x-k NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -37,7 +37,7 @@ import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Utils.Outputable import GHC.Utils.Misc @@ -46,7 +46,6 @@ import GHC.Utils.Panic.Plain import GHC.Data.Bag -import GHC.Types.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set import GHC.Types.Unique.DSet @@ -153,8 +152,8 @@ tc == tYPETyCon = Just [] | -- Similarly, treat `type data` declarations as empty data types on -- the term level, as `type data` data constructors only exist at - -- the type level (#22964). - -- See Note [Type data declarations] in GHC.Rename.Module. + -- the type level (#22964). See wrinkle (W2a) in + -- Note [Type data declarations] in GHC.Rename.Module. isTypeDataTyCon tc = Just [] | otherwise = tyConDataCons_maybe tc in vanillaCompleteMatch . mkUniqDSet . map RealDataCon <$> mb_dcs @@ -646,8 +645,7 @@ nameTyCt pred_ty = do unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) - idname = mkInternalName unique occname noSrcSpan - return (mkLocalIdOrCoVar idname ManyTy pred_ty) + return (mkUserLocalOrCoVar occname unique ManyTy pred_ty noSrcSpan) ----------------------------- -- ** Adding term constraints @@ -680,7 +678,7 @@ filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args = [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con) - , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ] + , isBanged bang || definitelyUnliftedType (idType arg) ] -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ -- surely diverges. Quite similar to 'addConCt', only that it only cares about @@ -692,7 +690,7 @@ IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction! IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do MaybeBot -- We add x ~ ⊥ - | Just Unlifted <- typeLevity_maybe (idType x) + | definitelyUnliftedType (idType x) -- Case (3) in Note [Strict fields and variables of unlifted type] -> mzero -- unlifted vars can never be ⊥ | otherwise diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -8,14 +8,15 @@ tracePm, traceWhenFailPm, mkPmId, allPmCheckWarnings, overlapping, exhaustive, redundantBang, exhaustiveWarningFlag, - isMatchContextPmChecked, needToRunPmCheck + isMatchContextPmChecked, isMatchContextPmChecked_SinglePat, + needToRunPmCheck ) where import GHC.Prelude -import GHC.Types.Basic (Origin(..), isGenerated) -import GHC.Driver.Session +import GHC.Types.Basic (Origin(..), requiresPMC) +import GHC.Driver.DynFlags import GHC.Hs import GHC.Core.Type import GHC.Data.FastString @@ -25,7 +26,6 @@ import GHC.Types.Name import GHC.Types.Unique.Supply import GHC.Types.SrcLoc -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.HsToCore.Monad @@ -51,8 +51,7 @@ mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" - name = mkInternalName unique occname noSrcSpan - in return (mkLocalIdOrCoVar name ManyTy ty) + in return (mkUserLocalOrCoVar occname unique ManyTy ty noSrcSpan) {-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough -- | All warning flags that need to run the pattern match checker. @@ -109,24 +108,36 @@ -- 'HsMatchContext' (does not matter whether it is the redundancy check or the -- exhaustiveness check). isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool -isMatchContextPmChecked dflags origin kind - | isGenerated origin +isMatchContextPmChecked dflags origin ctxt + = requiresPMC origin + && (overlapping dflags ctxt || exhaustive dflags ctxt) + +-- | Check whether exhaustivity checks are enabled for this 'HsMatchContext', +-- when dealing with a single pattern (using the 'matchSinglePatVar' function). +isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext id -> LPat GhcTc -> Bool +isMatchContextPmChecked_SinglePat dflags origin ctxt pat + | not (needToRunPmCheck dflags origin) = False + | StmtCtxt {} <- ctxt + -- For @StmtCtxt@, we are interested in propagating pattern-match information + -- but not in the actual outcome of pattern-match checking, so we skip + -- if the pattern is "boring" (gives rise to no long-distance information). + -- (This is done purely for runtime performance.) + = not (isBoringHsPat pat) -- See Note [Boring patterns] in GHC.Hs.Pat. | otherwise - = overlapping dflags kind || exhaustive dflags kind + = overlapping dflags ctxt || exhaustive dflags ctxt -- | Return True when any of the pattern match warnings ('allPmCheckWarnings') -- are enabled, in which case we need to run the pattern match checker. needToRunPmCheck :: DynFlags -> Origin -> Bool needToRunPmCheck dflags origin - | isGenerated origin - = False - | otherwise - = notNull (filter (`wopt` dflags) allPmCheckWarnings) + = requiresPMC origin + && any (`wopt` dflags) allPmCheckWarnings {- Note [Inaccessible warnings for record updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12957) +Consider (#12957): + data T a where T1 :: { x :: Int } -> T Bool T2 :: { x :: Int } -> T a @@ -135,8 +146,9 @@ f :: T Char -> T a f r = r { x = 3 } -The desugarer will conservatively generate a case for T1 even though -it's impossible: +In GHC.Tc.Gen.Expr.desugarRecordUpd, we will conservatively generate a case +for T1 even though it's impossible: + f r = case r of T1 x -> T1 3 -- Inaccessible branch T2 x -> T2 3 @@ -144,13 +156,14 @@ We don't want to warn about the inaccessible branch because the programmer didn't put it there! So we filter out the warning here. +The test case T12957a checks this. The same can happen for long distance term constraints instead of type constraints (#17783): - data T = A { x :: Int } | B { x :: Int } + data T = A { x :: Int } | B f r@A{} = r { x = 3 } - f _ = B 0 + f _ = B Here, the long distance info from the FunRhs match (@r ~ A x@) will make the clause matching on @B@ of the desugaring to @case@ redundant. It's generated 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 @@ -2,7 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -32,7 +34,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.HsToCore.Errors.Types import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) @@ -94,11 +96,10 @@ import Data.ByteString ( unpack ) import Control.Monad import Data.List (sort, sortBy) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), toList ) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Data.Foldable ( toList ) import GHC.Types.Name.Reader (RdrName(..)) data MetaWrappers = MetaWrappers { @@ -143,9 +144,9 @@ mkWpTyApps [m_var] tyWrapper t = mkAppTy m_var t debug = (quoteWrapper, monadWrapper, m_var) - q_f <- dsHsWrapper quoteWrapper - m_f <- dsHsWrapper monadWrapper - return (MetaWrappers q_f m_f tyWrapper debug) + dsHsWrapper quoteWrapper $ \q_f -> do { + dsHsWrapper monadWrapper $ \m_f -> do { + return (MetaWrappers q_f m_f tyWrapper debug) } } -- Turn A into m A wrapName :: Name -> MetaM Type @@ -513,7 +514,7 @@ ------------------------- repDataDefn :: Core TH.Name - -> Either (Core [(M (TH.TyVarBndr ()))]) + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) -- the repTyClD case (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -- the repDataFamInstD case @@ -536,7 +537,7 @@ derivs1 } } -repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] +repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> LHsType GhcRn -> MetaM (Core (M TH.Dec)) repSynDecl tc bndrs ty @@ -1179,6 +1180,17 @@ rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] rep_flag InferredSpec = rep2_nw inferredSpecName [] +instance RepTV (HsBndrVis GhcRn) TH.BndrVis where + tyVarBndrName = tyVarBndrVisTyConName + repPlainTV (MkC nm) vis = do { (MkC vis') <- rep_bndr_vis vis + ; rep2 plainBndrTVName [nm, vis'] } + repKindedTV (MkC nm) vis (MkC ki) = do { (MkC vis') <- rep_bndr_vis vis + ; rep2 kindedBndrTVName [nm, vis', ki] } + +rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis) +rep_bndr_vis HsBndrRequired = rep2_nw bndrReqName [] +rep_bndr_vis (HsBndrInvisible _) = rep2_nw bndrInvisName [] + addHsOuterFamEqnTyVarBinds :: HsOuterFamEqnTyVarBndrs GhcRn -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a))) @@ -1284,7 +1296,7 @@ addQTyVarBinds :: FreshOrReuse -> LHsQTyVars GhcRn -- the binders to be added - -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env + -> (Core [(M (TH.TyVarBndr TH.BndrVis))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) addQTyVarBinds fresh_or_reuse qtvs thing_inside = let HsQTvs { hsq_ext = imp_tvs @@ -1389,7 +1401,7 @@ f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsAppKindTy _ ty ki) = do +repTy (HsAppKindTy _ ty _ ki) = do ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1 @@ -1608,15 +1620,15 @@ = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds }) +repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } }) = do { x <- repLE e; fs <- repUpdFields flds; repRecUpd x fs } -repE (RecordUpd { rupd_flds = Right _ }) +repE e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {} }) = do -- Not possible due to elimination in the renamer. See Note -- [Handling overloaded and rebindable constructs] - panic "The impossible has happened!" + pprPanic "repE: unexpected overloaded record update" $ ppr e repE (ExprWithTySig _ e wc_ty) = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $ @@ -1745,10 +1757,10 @@ ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } -repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) +repUpdFields :: [LHsRecUpdField GhcRn GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld where - rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) + rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp)) rep_fld (L l fld) = case unLoc (hfbLHS fld) of Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hfbRHS fld) @@ -1899,12 +1911,18 @@ fun_matches = MG { mg_alts = (L _ [L _ (Match { m_pats = [] - , m_grhss = GRHSs _ guards wheres } - )]) } })) + , m_grhss = GRHSs _ guards wheres + -- For a variable declaration I'm pretty + -- sure we always have a FunRhs + , m_ctxt = FunRhs { mc_strictness = strictessAnn } + } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupNBinder fn - ; p <- repPvar fn' + ; p <- repPvar fn' >>= case strictessAnn of + SrcLazy -> repPtilde + SrcStrict -> repPbang + NoSrcStrict -> pure ; ans <- repVal p guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (locA loc, ans') } @@ -1925,15 +1943,6 @@ ; ans' <- wrapGenSyms ss ans ; return (locA loc, ans') } -rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) - = do { v' <- lookupBinder v - ; e2 <- repLE e - ; x <- repNormal e2 - ; patcore <- repPvar v' - ; empty_decls <- coreListM decTyConName [] - ; ans <- repVal patcore x empty_decls - ; return (srcLocSpan (getSrcLoc v), ans) } - rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn , psb_args = args , psb_def = pat @@ -1972,6 +1981,8 @@ wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec +rep_bind (L _ (VarBind { var_ext = x })) = dataConCantHappen x + repPatSynD :: Core TH.Name -> Core (M TH.PatSynArgs) -> Core (M TH.PatSynDir) @@ -2211,21 +2222,25 @@ globalVarExternal :: Module -> OccName -> DsM (Core TH.Name) globalVarExternal mod name_occ - = do { - - ; MkC mod <- coreStringLit name_mod + = do { MkC mod <- coreStringLit name_mod ; MkC pkg <- coreStringLit name_pkg ; MkC occ <- occNameLit name_occ - ; rep2_nwDsM mk_varg [pkg,mod,occ] } + ; if | isDataOcc name_occ + -> rep2_nwDsM mkNameG_dName [pkg,mod,occ] + | isVarOcc name_occ + -> rep2_nwDsM mkNameG_vName [pkg,mod,occ] + | isTcOcc name_occ + -> rep2_nwDsM mkNameG_tcName [pkg,mod,occ] + | Just con_fs <- fieldOcc_maybe name_occ + -> do { MkC con <- coreStringLit con_fs + ; rep2_nwDsM mkNameG_fldName [pkg,mod,con,occ] } + | otherwise + -> pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) + } where name_mod = moduleNameFS (moduleName mod) name_pkg = unitFS (moduleUnit mod) - mk_varg | isDataOcc name_occ = mkNameG_dName - | isVarOcc name_occ = mkNameG_vName - | isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) - lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) -> MetaM Type -- The type lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ; @@ -2537,7 +2552,7 @@ repData :: Bool -- ^ @True@ for a @type data@ declaration. -- See Note [Type data declarations] in GHC.Rename.Module -> Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M (TH.TyVarBndr ()))]) + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) (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)) @@ -2549,7 +2564,7 @@ = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] repNewtype :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M (TH.TyVarBndr ()))]) + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) (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)) @@ -2560,7 +2575,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 TH.BndrVis))] -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2613,12 +2628,13 @@ Overlapping _ -> just =<< dataCon overlappingDataConName Overlaps _ -> just =<< dataCon overlapsDataConName Incoherent _ -> just =<< dataCon incoherentDataConName + NonCanonical _ -> just =<< dataCon incoherentDataConName where nothing = coreNothing overlapTyConName 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 TH.BndrVis))] -> Core [TH.FunDep] -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -2667,13 +2683,13 @@ repTySynInst (MkC eqn) = rep2 tySynInstDName [eqn] -repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] +repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> 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 TH.BndrVis))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> MetaM (Core (M TH.Dec)) @@ -2681,7 +2697,7 @@ = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [(M (TH.TyVarBndr ()))] + -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> Core [(M TH.TySynEqn)] diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs --- a/compiler/GHC/HsToCore/Ticks.hs +++ b/compiler/GHC/HsToCore/Ticks.hs @@ -550,14 +550,16 @@ = do { rec_binds' <- addTickHsRecordBinds rec_binds ; return (expr { rcon_flds = rec_binds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds }) +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(RegularRecUpdFields { recUpdFields = flds }) }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds }) + ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) } +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(OverloadedRecUpdFields { olRecUpdFields = flds } ) }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } + ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) } addTickHsExpr (ExprWithTySig x e ty) = liftM3 ExprWithTySig @@ -1180,24 +1182,23 @@ , tick_label = boxLabel } - cc_name | topOnly = head decl_path - | otherwise = concat (intersperse "." decl_path) + cc_name | topOnly = mkFastString $ head decl_path + | otherwise = mkFastString $ concat (intersperse "." decl_path) env <- getEnv case tickishType env of HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me ProfNotes -> do - let nm = mkFastString cc_name - flavour <- mkHpcCCFlavour <$> getCCIndexM nm - let cc = mkUserCC nm (this_mod env) pos flavour + flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name + let cc = mkUserCC cc_name (this_mod env) pos flavour count = countEntries && tte_countEntries env return $ ProfNote cc count True{-scopes-} Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids SourceNotes | RealSrcSpan pos' _ <- pos -> - return $ SourceNote pos' cc_name + return $ SourceNote pos' $ LexicalFastString cc_name _otherwise -> panic "mkTickish: bad source span!" diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -1,5 +1,10 @@ {-# LANGUAGE TypeFamilies, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + -- Don't warn that `type instance DsForeignsHooks = ...` + -- is an orphan; see Note [The Decoupling Abstract Data Hack] + -- in GHC.Driver.Hooks + -- | Various types used during desugaring. module GHC.HsToCore.Types ( DsM, DsLclEnv(..), DsGblEnv(..), @@ -9,6 +14,7 @@ import GHC.Prelude (Int) import Data.IORef +import qualified Data.Set as S import GHC.Types.CostCentre.State import GHC.Types.Error @@ -73,6 +79,9 @@ -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc". -- The set of reaching values Nablas is augmented as we walk inwards, refined -- through each pattern match in turn + , dsl_unspecables :: S.Set EvVar + -- ^ See Note [Desugaring non-canonical evidence]: this field collects + -- all un-specialisable evidence variables in scope. } -- Inside [| |] brackets, the desugarer looks 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 @@ -35,6 +35,7 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe +import GHC.Data.FastString import Data.IORef import Data.List (sortBy) @@ -86,7 +87,7 @@ let all_home_ids = ue_all_home_unit_ids unit_env mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod dir_imp_mods used_names - let usages = mod_usages ++ [ UsageFile { usg_file_path = f + let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f , usg_file_hash = hash , usg_file_label = Nothing } | (f, hash) <- zip dependent_files hashes ] @@ -174,7 +175,7 @@ msg m = moduleNameString (moduleName m) ++ "[TH] changed" - fing mmsg fn = UsageFile fn <$> lookupFileCache fc fn <*> pure mmsg + fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg unlinkedToUsage m ul = case nameOfObject_maybe ul of 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 @@ -79,9 +79,8 @@ import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr -import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import GHC.Tc.Types.Evidence @@ -142,7 +141,7 @@ -- multiplicity stored within the variable -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. -selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (unLoc var)) +selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (localiseId (unLoc var))) selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) {- Note [Localise pattern binders] @@ -454,7 +453,7 @@ is disabled. -} -mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr +mkFailExpr :: HsMatchContext GhcTc -> Type -> DsM CoreExpr mkFailExpr ctxt ty = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) @@ -995,19 +994,10 @@ mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do - uq <- newUnique this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq OneTy boolTy - -- It's always sufficient to pattern-match on a boolean with - -- multiplicity 'One'. - let + let trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) - trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) - -- - return $ Case e bndr1 boolTy - [ Alt (DataAlt falseDataCon) [] falseBox - , Alt (DataAlt trueDataCon) [] trueBox - ] + return $ mkIfThenElse e trueBox falseBox 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 @@ -292,7 +292,7 @@ -- create an array of Names for the symbols and add them to the NameCache updateNameCache' name_cache $ \cache0 -> do mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name) - cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do + cache <- foldGet' (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do let mod = mkModule uid mod_name case lookupOrigNameCache cache mod occ of Just name -> do 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 @@ -24,7 +24,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Tc.Utils.Monad import GHC.Core.Type @@ -193,9 +193,12 @@ tcIfaceLclId :: FastString -> IfL Id tcIfaceLclId occ = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_id_env lcl) occ) of + ; case lookupFsEnv (if_id_env lcl) occ of Just ty_var -> return ty_var - Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) + Nothing -> failIfM $ + vcat + [ text "Iface id out of scope: " <+> ppr occ + , text "env:" <+> ppr (if_id_env lcl) ] } extendIfaceIdEnv :: [Id] -> IfL a -> IfL a @@ -209,7 +212,7 @@ tcIfaceTyVar :: FastString -> IfL TyVar tcIfaceTyVar occ = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_tv_env lcl) occ) of + ; case lookupFsEnv (if_tv_env lcl) occ of Just ty_var -> return ty_var Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) } @@ -262,9 +265,9 @@ newIfaceNames :: [OccName] -> IfL [Name] newIfaceNames occs - = do { uniqs <- newUniqueSupply + = do { uniqs <- getUniquesM ; return [ mkInternalName uniq occ noSrcSpan - | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } + | (occ,uniq) <- occs `zip` uniqs] } trace_if :: Logger -> SDoc -> IO () {-# INLINE trace_if #-} diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -3,95 +3,54 @@ module GHC.Iface.Errors ( badIfaceFile - , hiModuleNameMismatchWarn - , homeModError , cannotFindInterface , cantFindInstalledErr , cannotFindModule - , cantFindErr - -- * Utility functions - , mayShowLocations ) where import GHC.Platform.Profile import GHC.Platform.Ways import GHC.Utils.Panic.Plain -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env -import GHC.Driver.Errors.Types import GHC.Data.Maybe import GHC.Prelude import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder.Types import GHC.Utils.Outputable as Outputable +import GHC.Iface.Errors.Types +-- ----------------------------------------------------------------------------- +-- Error messages badIfaceFile :: String -> SDoc -> SDoc badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> SDoc -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), - sep [text "Probable cause: the source code which generated interface file", - text "has an incompatible module name" - ] - ] - | otherwise = - -- ToDo: This will fail to have enough qualification when the package IDs - -- are the same - withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ - -- we want the Modules below to be qualified with package names, - -- so reset the NamePprCtx setting. - hsep [ text "Something is amiss; requested module " - , ppr requested_mod - , text "differs from name found in the interface file" - , ppr read_mod - , parens (text "if these names look the same, try again with -dppr-debug") - ] - -homeModError :: InstalledModule -> ModLocation -> SDoc --- See Note [Home module load error] -homeModError mod location - = text "attempting to use module " <> quotes (ppr mod) - <> (case ml_hs_file location of - Just file -> space <> parens (text file) - Nothing -> Outputable.empty) - <+> text "which is not loaded" - - --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for") - (text "Ambiguous interface for") +cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile + -> ModuleName -> InstalledFindResult -> MissingInterfaceError +cannotFindInterface us mhu p mn ifr = + CantFindErr us FindingInterface $ + cantFindInstalledErr us mhu p mn ifr cantFindInstalledErr - :: SDoc - -> SDoc - -> UnitState + :: UnitState -> Maybe HomeUnit -> Profile - -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult - -> SDoc -cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result - = cannot_find <+> quotes (ppr mod_name) - $$ more_info + -> CantFindInstalled +cantFindInstalledErr unit_state mhome_unit profile mod_name find_result + = CantFindInstalled mod_name more_info where build_tag = waysBuildTag (profileWays profile) more_info = case find_result of InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg + -> NoUnitIdMatching pkg (searchPackageId unit_state (PackageId (unitIdFS pkg))) InstalledNotFound files mb_pkg | Just pkg <- mb_pkg @@ -99,152 +58,80 @@ -> not_found_in_package pkg files | null files - -> text "It is not a module in the current program, or in any known package." + -> NotAModule | otherwise - -> tried_these files + -> CouldntFindInFiles files _ -> panic "cantFindInstalledErr" - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id (i.e. an installed package component - -- identifier) into a PackageId and see if it means anything. - | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - not_found_in_package pkg files | build_tag /= "" = let build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files - + MissingPackageWayFiles build pkg files | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files + = MissingPackageFiles pkg files -mayShowLocations :: DynFlags -> [FilePath] -> SDoc -mayShowLocations dflags files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v (or `:set -v` in ghci) " <> - text "to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) -cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> MissingInterfaceError cannotFindModule hsc_env = cannotFindModule' - (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (targetProfile (hsc_dflags hsc_env)) -cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc -cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $ - cantFindErr (checkBuildingCabalPackage dflags) - cannotFindMsg - (text "Ambiguous module name") - unit_env +cannotFindModule' :: UnitEnv -> Profile -> ModuleName -> FindResult + -> MissingInterfaceError +cannotFindModule' unit_env profile mod res = + CantFindErr (ue_units unit_env) FindingModule $ + cantFindErr unit_env profile - (mayShowLocations dflags) mod res - where - cannotFindMsg = - case res of - NotFound { fr_mods_hidden = hidden_mods - , fr_pkgs_hidden = hidden_pkgs - , fr_unusables = unusables } - | not (null hidden_mods && null hidden_pkgs && null unusables) - -> text "Could not load module" - _ -> text "Could not find module" cantFindErr - :: BuildingCabalPackage -- ^ Using Cabal? - -> SDoc - -> SDoc - -> UnitEnv + :: UnitEnv -> Profile - -> ([FilePath] -> SDoc) -> ModuleName -> FindResult - -> SDoc -cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnit m : xs) - unambiguousPackage _ _ = Nothing - - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnit m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.mkUnit) res ++ - if f then [text "a package flag"] else [] - ) + -> CantFindInstalled +cantFindErr _ _ mod_name (FoundMultiple mods) + = CantFindInstalled mod_name (MultiplePackages mods) -cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result - = cannot_find <+> quotes (ppr mod_name) - $$ more_info +cantFindErr unit_env profile mod_name find_result + = CantFindInstalled mod_name more_info where mhome_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - + -> NoUnitIdMatching (toUnitId pkg) [] NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg , Nothing <- mhome_unit -- no home-unit - -> not_found_in_package pkg files + -> not_found_in_package (toUnitId pkg) files | Just pkg <- mb_pkg , Just home_unit <- mhome_unit -- there is a home-unit but the , not (isHomeUnit home_unit pkg) -- module isn't from it - -> not_found_in_package pkg files + -> not_found_in_package (toUnitId pkg) files | not (null suggest) - -> pp_suggestions suggest $$ tried_these files + -> ModuleSuggestion suggest files | null files && null mod_hiddens && null pkg_hiddens && null unusables - -> text "It is not a module in the current program, or in any known package." + -> NotAModule | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ - vcat (map unusable unusables) $$ - tried_these files - + -> GenericMissing + (map ((\uid -> (uid, lookupUnit (ue_units unit_env) uid))) pkg_hiddens) + mod_hiddens unusables files _ -> panic "cantFindErr" build_tag = waysBuildTag (profileWays profile) @@ -255,82 +142,7 @@ build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files + MissingPackageWayFiles build pkg files | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files - - pkg_hidden :: Unit -> SDoc - pkg_hidden uid = - text "It is a member of the hidden package" - <+> quotes (ppr uid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uid - - pkg_hidden_hint uid - | using_cabal == YesBuildingCabalPackage - = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid) - in text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - | Just pkg <- lookupUnit (ue_units unit_env) uid - = text "You can run" <+> - quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - unusable (UnusableUnit unit reason reexport) - = text "It is " <> (if reexport then text "reexported from the package" - else text "a member of the package") - <+> quotes (ppr unit) - $$ pprReason (text "which is") reason - - pp_suggestions :: [ModuleSuggestion] -> SDoc - pp_suggestions sugs - | null sugs = Outputable.empty - | otherwise = hang (text "Perhaps you meant") - 2 (vcat (map pp_sugg sugs)) - - -- NB: Prefer the *original* location, and then reexports, and then - -- package flags when making suggestions. ToDo: if the original package - -- also has a reexport, prefer that one - pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnit mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnit mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (mkUnit pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-id" - <+> ppr (moduleUnit mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (mkUnit pkg)) - | otherwise = Outputable.empty - + = MissingPackageFiles pkg files 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 @@ -41,6 +41,7 @@ import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.Name.Reader ( RecFieldInfo(..) ) import GHC.Types.SrcLoc import GHC.Core.Type ( Type ) import GHC.Core.Predicate @@ -570,7 +571,7 @@ HsOuterExplicit{hso_bndrs = tvs} -> foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c] -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg p tm ty) where loc (HsValArg tm) = loc tm loc (HsTypeArg _ ty) = loc ty loc (HsArgPar sp) = sp @@ -905,7 +906,7 @@ setOrigin :: Origin -> NodeOrigin -> NodeOrigin setOrigin FromSource _ = SourceInfo -setOrigin Generated _ = GeneratedInfo +setOrigin (Generated {}) _ = GeneratedInfo instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where toHie (L sp psb) = concatM $ case psb of @@ -1182,11 +1183,13 @@ con_name = case hiePass @p of -- Like ConPat HieRn -> con HieTc -> fmap conLikeName con - RecordUpd {rupd_expr = expr, rupd_flds = Left upds}-> + RecordUpd { rupd_expr = expr + , rupd_flds = RegularRecUpdFields { recUpdFields = upds } }-> [ toHie expr , toHie $ map (RC RecFieldAssign) upds ] - RecordUpd {rupd_expr = expr, rupd_flds = Right _}-> + RecordUpd { rupd_expr = expr + , rupd_flds = OverloadedRecUpdFields {} }-> [ toHie expr ] ExprWithTySig _ expr sig -> @@ -1773,7 +1776,7 @@ [ toHie a , toHie b ] - HsAppKindTy _ ty ki -> + HsAppKindTy _ ty _ ki -> [ toHie ty , toHie ki ] @@ -1831,7 +1834,7 @@ HsStarTy _ _ -> [] XHsType _ -> [] -instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where +instance (ToHie tm, ToHie ty) => ToHie (HsArg p tm ty) where toHie (HsValArg tm) = toHie tm toHie (HsTypeArg _ ty) = toHie ty toHie (HsArgPar sp) = locOnly sp @@ -2111,10 +2114,9 @@ IEThingAll _ n -> [ toHie $ IEC c n ] - IEThingWith flds n _ ns -> + IEThingWith _ n _ ns -> [ toHie $ IEC c n , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds ] IEModuleContents _ n -> [ toHie $ IEC c n @@ -2135,10 +2137,10 @@ [ toHie $ C (IEThing c) (L l n) ] -instance ToHie (IEContext (Located FieldLabel)) where - toHie (IEC c (L span lbl)) = concatM - [ makeNode lbl span - , toHie $ C (IEThing c) $ L span (flSelector lbl) +instance ToHie (IEContext (Located RecFieldInfo)) where + toHie (IEC c (L span info)) = concatM + [ makeNode info span + , toHie $ C (IEThing c) $ L span (flSelector $ recFieldLabel info) ] instance ToHie (LocatedA (DocDecl GhcRn)) where @@ -2149,4 +2151,5 @@ DocGroup _ d -> [ toHie d ] instance ToHie (LHsDoc GhcRn) where - toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids] + toHie (L span d@(WithHsDocIdentifiers _ ids)) = + concatM $ makeNode d span : [toHie $ map (C Use) ids] 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 @@ -9,7 +9,7 @@ import GHC.Prelude import GHC.Core.Map.Type -import GHC.Driver.Session ( DynFlags ) +import GHC.Driver.DynFlags ( DynFlags ) import GHC.Driver.Ppr import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type 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 @@ -30,6 +30,8 @@ moduleFreeHolesPrecise, needWiredInHomeIface, loadWiredInHomeIface, + WhereFrom(..), + pprModIfaceSimple, ifaceStats, pprModIface, showIface, @@ -47,7 +49,7 @@ import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Errors.Types -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -100,7 +102,6 @@ import GHC.Unit.External import GHC.Unit.Module -import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps import GHC.Unit.State @@ -116,6 +117,7 @@ import System.FilePath import System.Directory import GHC.Driver.Env.KnotVars +import GHC.Iface.Errors.Types {- ************************************************************************ @@ -143,7 +145,7 @@ also turn out to be needed by the code that e2 expands to. -} -tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing) +tcLookupImported_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name = do { hsc_env <- getTopEnv @@ -152,7 +154,7 @@ Just thing -> return (Succeeded thing) Nothing -> tcImportDecl_maybe name } -tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing) +tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) -- Entry point for *source-code* uses of importDecl tcImportDecl_maybe name | Just thing <- wiredInNameTyThing_maybe name @@ -163,7 +165,7 @@ | otherwise = initIfaceTcRn (importDecl name) -importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) +importDecl :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name @@ -174,29 +176,22 @@ -- Load the interface, which should populate the PTE ; mb_iface <- assertPpr (isExternalName name) (ppr name) $ loadInterface nd_doc (nameModule name) ImportBySystem - ; case mb_iface of { - Failed err_msg -> return (Failed err_msg) ; - Succeeded _ -> do + ; case mb_iface of + { Failed err_msg -> return $ Failed $ + Can'tFindInterface err_msg (LookingForName name) + ; Succeeded _ -> do -- Now look it up again; this time we should find it { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of Just thing -> return $ Succeeded thing - Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) - $$ not_found_msg - in return $ Failed doc + Nothing -> return $ Failed $ + Can'tFindNameInInterface name + (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps) }}} where nd_doc = text "Need decl for" <+> ppr name - not_found_msg = hang (text "Can't find interface-file declaration for" <+> - pprNameSpace (nameNameSpace name) <+> ppr name) - 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", - text "Use -ddump-if-trace to get an idea of which file caused the error"]) - found_things_msg eps = - hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) - 2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)) - where - is_interesting thing = nameModule name == nameModule (getName thing) + is_interesting thing = nameModule name == nameModule (getName thing) {- @@ -299,15 +294,21 @@ loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) - Succeeded iface -> return iface } + Failed err -> + failWithTc $ + TcRnInterfaceError $ + Can'tFindInterface err $ + LookingForModule mod want_boot + Succeeded iface -> + return iface + } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM (MaybeErr SDoc ModIface) + -> RnM (MaybeErr MissingInterfaceError ModIface) loadSrcInterface_maybe doc mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -403,11 +404,11 @@ = do dflags <- getDynFlags let ctx = initSDocContext dflags defaultUserStyle - withException ctx (loadInterface doc mod_name where_from) + withIfaceErr ctx (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr SDoc ModIface) + -> IfM lcl (MaybeErr MissingInterfaceError ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -703,7 +704,7 @@ -> SDoc -> IsBootInterface -> Module - -> IO (MaybeErr SDoc (ModIface, FilePath)) + -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath)) computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0)) let mhome_unit = hsc_home_unit_maybe hsc_env @@ -732,7 +733,7 @@ -- @p[A=\,B=\]:B@ never includes B. moduleFreeHolesPrecise :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName)) + -> TcRnIf gbl lcl (MaybeErr MissingInterfaceError (UniqDSet ModuleName)) moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = @@ -769,13 +770,13 @@ Failed err -> return (Failed err) wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr SDoc IsBootInterface + -> MaybeErr MissingInterfaceError IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile mhome_unit eps mod from = case from of ImportByUser usr_boot | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod - -> Failed (badSourceImport mod) + -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot ImportByPlugin @@ -798,11 +799,6 @@ -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules -badSourceImport :: Module -> SDoc -badSourceImport mod - = hang (text "You cannot {-# SOURCE #-} import a module from another package") - 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" - <+> quotes (ppr (moduleUnit mod))) ----------------------------------------------------- -- Loading type/class/value decls @@ -855,7 +851,7 @@ -- this to check the consistency of the requirements of the -- module we read out. -> IsBootInterface -- ^ Looking for .hi-boot or .hi file - -> IO (MaybeErr SDoc (ModIface, FilePath)) + -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath)) findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags @@ -897,12 +893,12 @@ Just home_unit | isHomeInstalledModule home_unit mod , not (isOneShot (ghcMode dflags)) - -> return (Failed (homeModError mod loc)) + -> return (Failed (HomeModError mod loc)) _ -> do r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) case r of - Failed _ - -> return r + Failed err + -> return (Failed $ BadIfaceFile err) Succeeded (iface,_fp) -> do r2 <- load_dynamic_too_maybe logger name_cache unit_state @@ -910,46 +906,47 @@ iface loc case r2 of Failed sdoc -> return (Failed sdoc) - Succeeded {} -> return r + Succeeded {} -> return $ Succeeded (iface,_fp) err -> do trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state mhome_unit profile - (Iface_Errors.mayShowLocations dflags) (moduleName mod) err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) +load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc -- Indefinite interfaces are ALWAYS non-dynamic. | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ()) | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc | otherwise = return (Succeeded ()) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) +load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> return (Succeeded ()) | otherwise -> - do return $ (Failed $ dynamicHashMismatchError wanted_mod loc) + do return $ (Failed $ DynamicHashMismatchError wanted_mod loc) Failed err -> - do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) + do return $ (Failed $ FailedToLoadDynamicInterface wanted_mod err) + --((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) -dynamicHashMismatchError :: Module -> ModLocation -> SDoc -dynamicHashMismatchError wanted_mod loc = - vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod) - , text "Normal interface file from" <+> text (ml_hi_file loc) - , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc) - , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] -read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath)) + +read_file :: Logger -> NameCache -> UnitState -> DynFlags + -> Module -> FilePath + -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do trace_if logger (text "readIFace" <+> text file_path) @@ -964,7 +961,7 @@ (uninstantiateInstantiatedModule indef_mod) read_result <- readIface dflags name_cache wanted_mod' file_path case read_result of - Failed err -> return (Failed (badIfaceFile file_path err)) + Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... @@ -985,7 +982,7 @@ -> NameCache -> Module -> FilePath - -> IO (MaybeErr SDoc ModIface) + -> IO (MaybeErr ReadInterfaceError ModIface) readIface dflags name_cache wanted_mod file_path = do let profile = targetProfile dflags res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path @@ -999,9 +996,9 @@ | otherwise -> return (Failed err) where actual_mod = mi_module iface - err = hiModuleNameMismatchWarn wanted_mod actual_mod + err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod - Left exn -> return (Failed (text (showException exn))) + Left exn -> return (Failed (ExceptionOccurred file_path exn)) {- ********************************************************* @@ -1146,8 +1143,8 @@ ] where pp_hsc_src HsBootFile = text "[boot]" - pp_hsc_src HsigFile = text "[hsig]" - pp_hsc_src HsSrcFile = Outputable.empty + pp_hsc_src HsigFile = text "[hsig]" + pp_hsc_src HsSrcFile = Outputable.empty {- When printing export lists, we print like this: @@ -1160,7 +1157,7 @@ pprExport (Avail n) = ppr n pprExport (AvailTC _ []) = Outputable.empty pprExport avail@(AvailTC n _) = - ppr n <> mark <> pp_export (availSubordinateGreNames avail) + ppr n <> mark <> pp_export (availSubordinateNames avail) where mark | availExportsDecl avail = Outputable.empty | otherwise = vbar @@ -1179,7 +1176,7 @@ ) pprUsage usage@UsageFile{} = hsep [text "addDependentFile", - doubleQuotes (text (usg_file_path usage)), + doubleQuotes (ftext (usg_file_path usage)), ppr (usg_file_hash usage)] pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] @@ -1208,16 +1205,6 @@ pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable (Warnings pass) where - ppr = pprWarns - -pprWarns :: Warnings pass -> SDoc -pprWarns NoWarnings = Outputable.empty -pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt -pprWarns (WarnSome prs) = text "Warnings:" - <+> vcat (map pprWarning prs) - where pprWarning (name, txt) = ppr name <+> ppr txt - pprIfaceAnnotation :: IfaceAnnotation -> SDoc pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) = ppr target <+> text "annotated by" <+> ppr serialized @@ -1226,3 +1213,20 @@ pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs where pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes" + + +-- | Reason for loading an interface file +-- +-- Used to figure out whether we want to consider loading hi-boot files or not. +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. + | ImportByPlugin -- Importing a plugin. + +instance Outputable WhereFrom where + ppr (ImportByUser IsBoot) = text "{- SOURCE -}" + ppr (ImportByUser NotBoot) = empty + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" + + 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 @@ -14,8 +14,6 @@ , mkFullIface , mkIfaceTc , mkIfaceExports - , coAxiomToIfaceDecl - , tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -23,11 +21,13 @@ import GHC.Hs +import GHC.Stg.InferTags.TagSig (StgCgInfos) import GHC.StgToCmm.Types (CmmCgInfos (..)) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad +import GHC.Iface.Decl import GHC.Iface.Syntax import GHC.Iface.Recomp import GHC.Iface.Load @@ -38,13 +38,8 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Core import GHC.Core.Class -import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.FVs ( orphNamesOfAxiomLHS ) -import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Ppr @@ -53,32 +48,30 @@ import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Plugins import GHC.Types.Id import GHC.Types.Fixity.Env import GHC.Types.SafeHaskell import GHC.Types.Annotations -import GHC.Types.Var.Env -import GHC.Types.Var import GHC.Types.Name import GHC.Types.Avail import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Unique.DSet -import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.TyThing import GHC.Types.HpcInfo import GHC.Types.CompleteMatch +import GHC.Types.SourceText +import GHC.Types.SrcLoc ( unLoc ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Data.FastString @@ -96,10 +89,9 @@ import GHC.Unit.Module.Deps import Data.Function -import Data.List ( findIndex, mapAccumL, sortBy ) +import Data.List ( sortBy ) import Data.Ord import Data.IORef -import GHC.Stg.Pipeline (StgCgInfos) {- @@ -301,13 +293,14 @@ -- The order of fixities returned from nonDetNameEnvElts is not -- deterministic, so we sort by OccName to canonicalize it. -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. - warns = src_warns + warns = toIfaceWarnings src_warns iface_rules = map coreRuleToIfaceRule rules iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts) iface_fam_insts = map famInstToIfaceFamInst fam_insts trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns icomplete_matches = map mkIfaceCompleteMatch complete_matches + !rdrs = maybeGlobalRdrEnv rdr_env ModIface { mi_module = this_mod, @@ -330,7 +323,7 @@ mi_fixities = fixities, mi_warns = warns, mi_anns = annotations, - mi_globals = maybeGlobalRdrEnv rdr_env, + mi_globals = rdrs, mi_used_th = used_th, mi_decls = decls, mi_extra_decls = extra_decls, @@ -358,14 +351,96 @@ -- Desugar.addExportFlagsAndRules). The mi_globals field is used -- by GHCi to decide whether the module has its full top-level -- scope available. (#5534) - maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe IfGlobalRdrEnv maybeGlobalRdrEnv rdr_env - | backendWantsGlobalBindings (backend dflags) = Just rdr_env - | otherwise = Nothing + | backendWantsGlobalBindings (backend dflags) + = Just $! forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + | otherwise + = Nothing ifFamInstTcName = ifFamInstFam +-------------------------- +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag + , is_cls_nm = cls_name, is_cls = cls + , is_tcs = rough_tcs + , is_orphan = orph }) + = assert (cls_name == className cls) $ + IfaceClsInst { ifDFun = idName dfun_id + , ifOFlag = oflag + , ifInstCls = cls_name + , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs + -- N.B. Drop the class name from the rough match template + -- It is put back by GHC.Core.InstEnv.mkImportedClsInst + , ifInstOrph = orph } + +-------------------------- +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst (FamInst { fi_axiom = axiom + , fi_fam = fam + , fi_tcs = rough_tcs + , fi_orphan = orphan }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = ifaceRoughMatchTcs rough_tcs + , ifFamInstOrph = orphan } + +ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] +ifaceRoughMatchTcs tcs = map do_rough tcs + where + do_rough RM_WildCard = Nothing + do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n) + +-------------------------- +toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings +toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt) +toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' + where + vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs] + ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] + +toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt +toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs) + +toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName]) +toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) + +toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral +toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs + +coreRuleToIfaceRule :: CoreRule -> IfaceRule +-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should +-- ensure that there's another CoreDoPluginPass that removes the rule. +-- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas +-- would cause panic when the rule is attempted to be written to the interface file. +coreRuleToIfaceRule rule@(BuiltinRule {}) + = pprPanic "toHsRule:" (pprRule rule) + +coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, + ru_orphan = orph, ru_auto = auto }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr rhs, + ifRuleAuto = auto, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) + do_arg arg = toIfaceExpr arg + + {- ************************************************************************ * * @@ -403,8 +478,10 @@ sort_subs (Avail n) = Avail n sort_subs (AvailTC n []) = AvailTC n [] sort_subs (AvailTC n (m:ms)) - | NormalGreName n==m = AvailTC n (m:sortBy stableGreNameCmp ms) - | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms)) + | n == m + = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise + = AvailTC n (sortBy stableNameCmp (m:ms)) -- Maintain the AvailTC Invariant {- @@ -423,362 +500,3 @@ In the result of mkIfaceExports, the names are grouped by defining module, so we may need to split up a single Avail into multiple ones. -} - - -{- -************************************************************************ -* * - Converting things to their Iface equivalents -* * -************************************************************************ --} - -tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl -tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) -tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of - RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only - PatSynCon ps -> patSynToIfaceDecl ps - --------------------------- -idToIfaceDecl :: Id -> IfaceDecl --- The Id is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- We can't tidy it here, locally, because it may have --- free variables in its type or IdInfo -idToIfaceDecl id - = IfaceId { ifName = getName id, - ifType = toIfaceType (idType id), - ifIdDetails = toIfaceIdDetails (idDetails id), - ifIdInfo = toIfaceIdInfo (idInfo id) } - --------------------------- -dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl -dataConToIfaceDecl show_linear_types dataCon - = IfaceId { ifName = getName dataCon, - ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), - ifIdDetails = IfVanillaId, - ifIdInfo = [] } - --------------------------- -coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl --- We *do* tidy Axioms, because they are not (and cannot --- conveniently be) built in tidy form -coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches - , co_ax_role = role }) - = IfaceAxiom { ifName = getName ax - , ifTyCon = toIfaceTyCon tycon - , ifRole = role - , ifAxBranches = map (coAxBranchToIfaceBranch tycon - (map coAxBranchLHS branch_list)) - branch_list } - where - branch_list = fromBranches branches - --- 2nd parameter is the list of branch LHSs, in case of a closed type family, --- for conversion from incompatible branches to incompatible indices. --- For an open type family the list should be empty. --- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom -coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch tc lhs_s - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_eta_tvs = eta_tvs - , cab_lhs = lhs, cab_roles = roles - , cab_rhs = rhs, cab_incomps = incomps }) - - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs - , ifaxbCoVars = map toIfaceIdBndr cvs - , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs - , ifaxbLHS = toIfaceTcArgs tc lhs - , ifaxbRoles = roles - , ifaxbRHS = toIfaceType rhs - , ifaxbIncomps = iface_incomps } - where - iface_incomps = map (expectJust "iface_incomps" - . flip findIndex lhs_s - . eqTypes - . coAxBranchLHS) incomps - ------------------ -tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) --- We *do* tidy TyCons, because they are not (and cannot --- conveniently be) built in tidy form --- The returned TidyEnv is the one after tidying the tyConTyVars -tyConToIfaceDecl env tycon - | Just clas <- tyConClass_maybe tycon - = classToIfaceDecl env clas - - | Just syn_rhs <- synTyConRhs_maybe tycon - = ( tc_env1 - , IfaceSynonym { ifName = getName tycon, - ifRoles = tyConRoles tycon, - ifSynRhs = if_syn_type syn_rhs, - ifBinders = if_binders, - ifResKind = if_res_kind - }) - - | Just fam_flav <- famTyConFlav_maybe tycon - = ( tc_env1 - , IfaceFamily { ifName = getName tycon, - ifResVar = if_res_var, - ifFamFlav = to_if_fam_flav fam_flav, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifFamInj = tyConInjectivityInfo tycon - }) - - | isAlgTyCon tycon - = ( tc_env1 - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = tyConCType_maybe tycon, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifParent = parent }) - - | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon - -- We only convert these TyCons to IfaceTyCons when we are - -- just about to pretty-print them, not because we are going - -- to put them into interface files - = ( env - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = Nothing, - ifRoles = tyConRoles tycon, - ifCtxt = [], - ifCons = IfDataTyCon False [], - ifGadtSyntax = False, - ifParent = IfNoParent }) - where - -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` - -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause - -- an error. - (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - tc_tyvars = binderVars tc_binders - if_binders = toIfaceForAllBndrs tc_binders - -- No tidying of the binders; they are already tidy - if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) - if_syn_type ty = tidyToIfaceType tc_env1 ty - if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon - - parent = case tyConFamInstSig_maybe tycon of - Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) - (toIfaceTyCon tc) - (tidyToIfaceTcArgs tc_env1 tc ty) - Nothing -> IfNoParent - - to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon - to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon - to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon - to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) - = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) - where defs = fromBranches $ coAxiomBranches ax - lhss = map coAxBranchLHS defs - ibr = map (coAxBranchToIfaceBranch tycon lhss) defs - axn = coAxiomName ax - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data }) - = IfDataTyCon type_data (map ifaceConDecl cons) - ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon False [ifaceConDecl con] - ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon False (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The AbstractTyCon case happens when a TyCon has been trimmed - -- during tidying. - -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module - -- for GHCi, when browsing a module, in which case the - -- AbstractTyCon and TupleTyCon cases are perfectly sensible. - -- (Tuple declarations are not serialised into interface files.) - - ifaceConDecl data_con - = IfCon { ifConName = dataConName data_con, - ifConInfix = dataConIsInfix data_con, - ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConExTCvs = map toIfaceBndr ex_tvs', - ifConUserTvBinders = toIfaceForAllBndrs user_bndrs', - ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, - ifConCtxt = tidyToIfaceContext con_env2 theta, - ifConArgTys = - map (\(Scaled w t) -> (tidyToIfaceType con_env2 w - , (tidyToIfaceType con_env2 t))) arg_tys, - ifConFields = dataConFieldLabels data_con, - ifConStricts = map (toIfaceBang con_env2) - (dataConImplBangs data_con), - ifConSrcStricts = map toIfaceSrcBang - (dataConSrcBangs data_con)} - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - user_bndrs = dataConUserTyVarBinders data_con - - -- Tidy the univ_tvs of the data constructor to be identical - -- to the tyConTyVars of the type constructor. This means - -- (a) we don't need to redundantly put them into the interface file - -- (b) when pretty-printing an Iface data declaration in H98-style syntax, - -- we know that the type variables will line up - -- The latter (b) is important because we pretty-print type constructors - -- by converting to Iface syntax and pretty-printing that - con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) - -- A bit grimy, perhaps, but it's simple! - - (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs - user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs - to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) - - -- By this point, we have tidied every universal and existential - -- tyvar. Because of the dcUserForAllTyBinders invariant - -- (see Note [DataCon user type variable binders]), *every* - -- user-written tyvar must be contained in the substitution that - -- tidying produced. Therefore, tidying the user-written tyvars is a - -- simple matter of looking up each variable in the substitution, - -- which tidyTyCoVarOcc accomplishes. - tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder - tidyUserForAllTyBinder env (Bndr tv vis) = - Bndr (tidyTyCoVarOcc env tv) vis - -classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) -classToIfaceDecl env clas - = ( env1 - , IfaceClass { ifName = getName tycon, - ifRoles = tyConRoles (classTyCon clas), - ifBinders = toIfaceForAllBndrs tc_binders, - ifBody = body, - ifFDs = map toIfaceFD clas_fds }) - where - (_, clas_fds, sc_theta, _, clas_ats, op_stuff) - = classExtraBigSig clas - tycon = classTyCon clas - - body | isAbstractTyCon tycon = IfAbstractClass - | otherwise - = IfConcreteClass { - ifClassCtxt = tidyToIfaceContext env1 sc_theta, - ifATs = map toIfaceAT clas_ats, - ifSigs = map toIfaceClassOp op_stuff, - ifMinDef = fmap getOccFS (classMinimalDef clas) - } - - (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - - toIfaceAT :: ClassATItem -> IfaceAT - toIfaceAT (ATI tc def) - = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) - where - (env2, if_decl) = tyConToIfaceDecl env1 tc - - toIfaceClassOp (sel_id, def_meth) - = assert (sel_tyvars == binderVars tc_binders) $ - IfaceClassOp (getName sel_id) - (tidyToIfaceType env1 op_ty) - (fmap toDmSpec def_meth) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id) - op_ty = funResultTy rho_ty - - toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType - toDmSpec (_, VanillaDM) = VanillaDM - toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) - - toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 - ,map (tidyTyVar env1) tvs2) - --------------------------- - -tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) --- If the type variable "binder" is in scope, don't re-bind it --- In a class decl, for example, the ATD binders mention --- (amd must mention) the class tyvars -tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) - = case lookupVarEnv subst tv of - Just tv' -> (env, Bndr tv' vis) - Nothing -> tidyForAllTyBinder env tvb - -tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) -tidyTyConBinders = mapAccumL tidyTyConBinder - -tidyTyVar :: TidyEnv -> TyVar -> FastString -tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) - --------------------------- -instanceToIfaceInst :: ClsInst -> IfaceClsInst -instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag - , is_cls_nm = cls_name, is_cls = cls - , is_tcs = rough_tcs - , is_orphan = orph }) - = assert (cls_name == className cls) $ - IfaceClsInst { ifDFun = idName dfun_id - , ifOFlag = oflag - , ifInstCls = cls_name - , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs - -- N.B. Drop the class name from the rough match template - -- It is put back by GHC.Core.InstEnv.mkImportedInstance - , ifInstOrph = orph } - --------------------------- -famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst (FamInst { fi_axiom = axiom, - fi_fam = fam, - fi_tcs = rough_tcs }) - = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom - , ifFamInstFam = fam - , ifFamInstTys = ifaceRoughMatchTcs rough_tcs - , ifFamInstOrph = orph } - where - fam_decl = tyConName $ coAxiomTyCon axiom - mod = assert (isExternalName (coAxiomName axiom)) $ - nameModule (coAxiomName axiom) - is_local name = nameIsLocalOrFrom mod name - - lhs_names = filterNameSet is_local (orphNamesOfAxiomLHS axiom) - - orph | is_local fam_decl - = NotOrphan (nameOccName fam_decl) - | otherwise - = chooseOrphanAnchor lhs_names - -ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] -ifaceRoughMatchTcs tcs = map do_rough tcs - where - do_rough RM_WildCard = Nothing - do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n) - --------------------------- -coreRuleToIfaceRule :: CoreRule -> IfaceRule --- A plugin that installs a BuiltinRule in a CoreDoPluginPass should --- ensure that there's another CoreDoPluginPass that removes the rule. --- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas --- would cause panic when the rule is attempted to be written to the interface file. -coreRuleToIfaceRule rule@(BuiltinRule {}) - = pprPanic "toHsRule:" (pprRule rule) - -coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, - ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, - ru_orphan = orph, ru_auto = auto }) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map toIfaceBndr bndrs, - ifRuleHead = fn, - ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr rhs, - ifRuleAuto = auto, - ifRuleOrph = orph } - where - -- For type args we must remove synonyms from the outermost - -- level. Reason: so that when we read it back in we'll - -- construct the same ru_rough field as we have right now; - -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) - do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) - do_arg arg = toIfaceExpr arg 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 @@ -24,7 +24,7 @@ import GHC.Driver.Backend import GHC.Driver.Config.Finder import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Plugins @@ -56,9 +56,9 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc -import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env +import GHC.Types.Unique.Map import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -83,6 +83,7 @@ import Data.Ord import Data.Containers.ListUtils import Data.Bifunctor +import GHC.Iface.Errors.Ppr {- ----------------------------------------------- @@ -196,6 +197,7 @@ | MismatchedDynHiFile | ObjectsChanged | LibraryChanged + | THWithJS deriving (Eq) instance Outputable RecompReason where @@ -228,6 +230,7 @@ MismatchedDynHiFile -> text "Mismatched dynamic interface file" ObjectsChanged -> text "Objects changed" LibraryChanged -> text "Library changed" + THWithJS -> text "JS backend always recompiles modules using Template Haskell for now (#23013)" recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False @@ -292,8 +295,13 @@ read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do - trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err) - trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err) + let msg = readInterfaceErrorDiagnostic err + trace_if logger + $ vcat [ text "FYI: cannot read old interface file:" + , nest 4 msg ] + trace_hi_diffs logger $ + vcat [ text "Old interface file was invalid:" + , nest 4 msg ] return Nothing Succeeded iface -> do trace_if logger (text "Read the interface file" <+> text iface_path) @@ -559,8 +567,8 @@ let logger = hsc_logger hsc_env let unit_state = hsc_units hsc_env let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] - new_merged = case Map.lookup (ms_mod_name mod_summary) - (requirementContext unit_state) of + new_merged = case lookupUniqMap (requirementContext unit_state) + (ms_mod_name mod_summary) of Nothing -> [] Just r -> sort $ map (instModuleToModule unit_state) r if old_merged == new_merged @@ -765,12 +773,12 @@ usg_file_label = mlabel } = liftIO $ handleIO handler $ do - new_hash <- lookupFileCache fc file + new_hash <- lookupFileCache fc $ unpackFS file if (old_hash /= new_hash) then return recomp else return UpToDate where - reason = FileChanged file + reason = FileChanged $ unpackFS file recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel handler = if debugIsOn then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp @@ -956,7 +964,8 @@ eps <- hscEPS hsc_env let decls = mi_decls iface0 - warn_fn = mkIfaceWarnCache (mi_warns iface0) + decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings $ mi_warns iface0) + export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ mi_warns iface0) fix_fn = mkIfaceFixCache (mi_fixities iface0) -- The ABI of a declaration represents everything that is made @@ -979,8 +988,8 @@ -- This is computed by finding the free external names of each -- declaration, including IfaceDeclExtras (things that a -- declaration implicitly depends on). - edges :: [ Node Unique IfaceDeclABI ] - edges = [ DigraphNode abi (getUnique (getOccName decl)) out + edges :: [ Node OccName IfaceDeclABI ] + edges = [ DigraphNode abi (getOccName decl) out | decl <- decls , let abi = declABI decl , let out = localOccs $ freeNamesDeclABI abi @@ -988,7 +997,7 @@ name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n) localOccs = - map (getUnique . getParent . getOccName) + map (getParent . getOccName) -- NB: names always use semantic module, so -- filtering must be on the semantic module! -- See Note [Identity versus semantic module] @@ -1013,7 +1022,7 @@ -- Strongly-connected groups of declarations, in dependency order groups :: [SCC IfaceDeclABI] - groups = stronglyConnCompFromEdgedVerticesUniq edges + groups = stronglyConnCompFromEdgedVerticesOrd edges global_hash_fn = mkHashFun hsc_env eps @@ -1205,7 +1214,11 @@ -- This key is safe because mi_extra_decls contains tidied things. getOcc (IfGblTopBndr b) = getOccName b - getOcc (IfLclTopBndr fs _ _ _) = mkVarOccFS fs + getOcc (IfLclTopBndr fs _ _ details) = + case details of + IfRecSelId { ifRecSelFirstCon = first_con } + -> mkRecFieldOccFS (getOccFS first_con) fs + _ -> mkVarOccFS fs binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) () binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs) @@ -1253,22 +1266,23 @@ let final_iface_exts = ModIfaceBackend - { mi_iface_hash = iface_hash - , mi_mod_hash = mod_hash - , mi_flag_hash = flag_hash - , mi_opt_hash = opt_hash - , mi_hpc_hash = hpc_hash - , mi_plugin_hash = plugin_hash - , mi_orphan = not ( all ifRuleAuto orph_rules - -- See Note [Orphans and auto-generated rules] - && null orph_insts - && null orph_fis) - , mi_finsts = not (null (mi_fam_insts iface0)) - , mi_exp_hash = export_hash - , mi_orphan_hash = orphan_hash - , mi_warn_fn = warn_fn - , mi_fix_fn = fix_fn - , mi_hash_fn = lookupOccEnv local_env + { mi_iface_hash = iface_hash + , mi_mod_hash = mod_hash + , mi_flag_hash = flag_hash + , mi_opt_hash = opt_hash + , mi_hpc_hash = hpc_hash + , mi_plugin_hash = plugin_hash + , mi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_finsts = not (null (mi_fam_insts iface0)) + , mi_exp_hash = export_hash + , mi_orphan_hash = orphan_hash + , mi_decl_warn_fn = decl_warn_fn + , mi_export_warn_fn = export_warn_fn + , mi_fix_fn = fix_fn + , mi_hash_fn = lookupOccEnv local_env } final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts } -- @@ -1319,7 +1333,7 @@ dflags = hsc_dflags hsc_env ctx = initSDocContext dflags defaultUserStyle get_orph_hash mod = do - iface <- initIfaceLoad hsc_env . withException ctx + iface <- initIfaceLoad hsc_env . withIfaceErr ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem return (mi_orphan_hash (mi_final_exts iface)) @@ -1614,7 +1628,7 @@ -- requirements; we didn't do any /real/ typechecking -- so there's no guarantee everything is loaded. -- Kind of a heinous hack. - initIfaceLoad hsc_env . withException ctx + initIfaceLoad hsc_env . withIfaceErr ctx $ withoutDynamicNow -- If you try and load interfaces when dynamic-too -- enabled then it attempts to load the dyn_hi and hi diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -70,10 +70,7 @@ -- Other flags which affect code generation codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) - -- Did we include core for all bindings? - fat_iface = gopt Opt_WriteIfSimplifiedCore dflags - - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags 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 @@ -231,14 +231,14 @@ return (renameHoleModule unit_state hmap mod) rnAvailInfo :: Rename AvailInfo -rnAvailInfo (Avail c) = Avail <$> rnGreName c +rnAvailInfo (Avail c) = Avail <$> rnIfaceGlobal c rnAvailInfo (AvailTC n ns) = do -- Why don't we rnIfaceGlobal the availName itself? It may not -- actually be exported by the module it putatively is from, in -- which case we won't be able to tell what the name actually -- is. But for the availNames they MUST be exported, so they -- will rename fine. - ns' <- mapM rnGreName ns + ns' <- mapM rnIfaceGlobal ns case ns' of [] -> panic "rnAvailInfoEmpty AvailInfo" (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest) @@ -246,11 +246,7 @@ n' <- setNameModule (Just (childModule rep)) n return (AvailTC n' ns') where - childModule = nameModule . greNameMangledName - -rnGreName :: Rename GreName -rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n -rnGreName (FieldGreName fl) = FieldGreName <$> rnFieldLabel fl + childModule = nameModule rnFieldLabel :: Rename FieldLabel rnFieldLabel fl = do @@ -258,8 +254,6 @@ return (fl { flSelector = sel' }) - - -- | The key function. This gets called on every Name embedded -- inside a ModIface. Our job is to take a Name from some -- generalized unit ID p[A=\, B=\], and change @@ -704,9 +698,12 @@ rnIfaceExprs = mapM rnIfaceExpr rnIfaceIdDetails :: Rename IfaceIdDetails -rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b -rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b -rnIfaceIdDetails details = pure details +rnIfaceIdDetails (IfRecSelId (Left tc) con naughty fl) + = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails (IfRecSelId (Right decl) con naughty fl) + = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails details + = pure details rnIfaceType :: Rename IfaceType rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) 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 @@ -615,11 +615,8 @@ getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc - | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) - | otherwise = [] - -- The 'otherwise' includes family TyCons of course, but also (less obviously) - -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make - -- * type data: we don't want any code for type-only stuff (#24620) + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -10,6 +10,8 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecursiveDo #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} @@ -33,8 +35,6 @@ import GHC.ByteCode.Types -import Data.Word - import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Config.Core.Lint ( initLintConfig ) @@ -42,6 +42,7 @@ import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Builtin.Types +import GHC.Iface.Decl (toIfaceBooleanFormula) import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env @@ -112,7 +113,6 @@ import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Set import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info @@ -130,6 +130,7 @@ import Data.IORef import Data.Foldable import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) +import GHC.Iface.Errors.Types {- This module takes @@ -288,7 +289,7 @@ (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) in d1 { ifBody = (ifBody d1) { ifSigs = ops, - ifMinDef = BF.mkOr [noLocA bf1, noLocA bf2] + ifMinDef = toIfaceBooleanFormula . BF.mkOr . map (noLocA . fromIfaceBooleanFormula) $ [bf1, bf2] } } `withRolesFrom` d2 -- It doesn't matter; we'll check for consistency later when @@ -565,7 +566,7 @@ then do { (_, hug) <- getEpsAndHug ; case lookupHugByModule mod hug of Just info | mi_boot (hm_iface info) == IsBoot - -> mkSelfBootInfo (hm_iface info) (hm_details info) + -> return $ SelfBoot { sb_mds = hm_details info } _ -> return NoSelfBoot } else do @@ -574,13 +575,14 @@ -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { hsc_env <- getTopEnv - ; read_result <- liftIO $ findAndReadIface hsc_env - need (fst (getModuleInstantiation mod)) mod - IsBoot -- Hi-boot file + ; read_result <- liftIO $ findAndReadIface hsc_env need + (fst (getModuleInstantiation mod)) mod + IsBoot -- Hi-boot file ; case read_result of { - Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface - ; mkSelfBootInfo iface tc_iface } ; + Succeeded (iface, _path) -> + do { tc_iface <- initIfaceTcRn $ typecheckIface iface + ; return $ SelfBoot { sb_mds = tc_iface } } ; Failed err -> -- There was no hi-boot file. But if there is circularity in @@ -596,9 +598,12 @@ Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints (elaborate err)) + IsBoot -> + let diag = Can'tFindInterface err + (LookingForHiBoot mod) + in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -606,36 +611,6 @@ need = text "Need the hi-boot interface for" <+> ppr mod <+> text "to compare against the Real Thing" - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - elaborate err = hang (text "Could not find hi-boot interface for" <+> - quotes (ppr mod) <> colon) 4 err - - -mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo -mkSelfBootInfo iface mds - = do -- NB: This is computed DIRECTLY from the ModIface rather - -- than from the ModDetails, so that we can query 'sb_tcs' - -- WITHOUT forcing the contents of the interface. - let tcs = map ifName - . filter isIfaceTyCon - . map snd - $ mi_decls iface - return $ SelfBoot { sb_mds = mds - , sb_tcs = mkNameSet tcs } - where - -- Returns @True@ if, when you call 'tcIfaceDecl' on - -- this 'IfaceDecl', an ATyCon would be returned. - -- NB: This code assumes that a TyCon cannot be implicit. - isIfaceTyCon IfaceId{} = False - isIfaceTyCon IfaceData{} = True - isIfaceTyCon IfaceSynonym{} = True - isIfaceTyCon IfaceFamily{} = True - isIfaceTyCon IfaceClass{} = True - isIfaceTyCon IfaceAxiom{} = False - isIfaceTyCon IfacePatSyn{} = False - {- ************************************************************************ * * @@ -699,7 +674,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, ifIdDetails = details, ifIdInfo = info}) = do { ty <- tcIfaceType iface_type - ; details <- tcIdDetails ty details + ; details <- tcIdDetails name ty details ; info <- tcIdInfo ignore_prags TopLevel name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -797,7 +772,7 @@ ifBody = IfConcreteClass { ifClassCtxt = rdr_ctxt, ifATs = rdr_ats, ifSigs = rdr_sigs, - ifMinDef = mindef_occ + ifMinDef = if_mindef }}) = bindIfaceTyConBinders binders $ \ binders' -> do { traceIf (text "tc-iface-class1" <+> ppr tc_name) @@ -806,6 +781,7 @@ ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; traceIf (text "tc-iface-class3" <+> ppr tc_name) + ; let mindef_occ = fromIfaceBooleanFormula if_mindef ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats @@ -955,10 +931,15 @@ return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy]) | otherwise = tcIfaceExtId gbl_name mk_top_id (IfLclTopBndr raw_name iface_type info details) = do - name <- newIfaceName (mkVarOccFS raw_name) ty <- tcIfaceType iface_type + rec { details' <- tcIdDetails name ty details + ; let occ = case details' of + RecSelId { sel_tycon = parent } + -> let con_fs = getOccFS $ recSelFirstConName parent + in mkRecFieldOccFS con_fs raw_name + _ -> mkVarOccFS raw_name + ; name <- newIfaceName occ } info' <- tcIdInfo False TopLevel name ty info - details' <- tcIdDetails ty details let new_id = mkGlobalId details' name ty info' return new_id @@ -1250,17 +1231,18 @@ = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ fmap tyThingId (tcIfaceImplicit dfun_name) ; let mb_tcs' = map tcRoughTyCon mb_tcs - ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } + ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs - , ifFamInstAxiom = axiom_name } ) + , ifFamInstAxiom = axiom_name + , ifFamInstOrph = orphan } ) = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ tcIfaceCoAxiom axiom_name -- will panic if branched, but that's OK ; let axiom'' = toUnbranchedAxiom axiom' mb_tcs' = map tcRoughTyCon mb_tcs - ; return (mkImportedFamInst fam mb_tcs' axiom'') } + ; return (mkImportedFamInst fam mb_tcs' axiom'' orphan) } {- ************************************************************************ @@ -1640,7 +1622,7 @@ tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) -tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) +tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) ------------------------- tcIfaceLit :: Literal -> IfL Literal @@ -1673,8 +1655,7 @@ tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr -> IfL CoreAlt tcIfaceDataAlt mult con inst_tys arg_strs rhs - = do { us <- newUniqueSupply - ; let uniqs = uniqsFromSupply us + = do { uniqs <- getUniquesM ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs mult con inst_tys @@ -1691,19 +1672,19 @@ ************************************************************************ -} -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds -tcIdDetails ty IfDFunId +tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds +tcIdDetails _ ty IfDFunId = return (DFunId (isNewTyCon (classTyCon cls))) where (_, _, cls, _) = tcSplitDFunTy ty -tcIdDetails _ (IfRecSelId tc naughty) +tcIdDetails nm _ (IfRecSelId tc _first_con naughty fl) = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) tc - ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty, sel_fieldLabel = fl { flSelector = nm } }) } where tyThingPatSyn (AConLike (PatSynCon ps)) = ps tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" @@ -1961,7 +1942,7 @@ { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of - Failed err -> failIfM (ppr name <+> err) + Failed err -> failIfM (ppr name <+> pprDiagnostic err) Succeeded thing -> return thing }}} @@ -2181,7 +2162,7 @@ -- CgBreakInfo -hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type) +hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word)], Type) hydrateCgBreakInfo CgBreakInfo{..} = do bindIfaceTyVars cgb_tyvars $ \_ -> do result_ty <- tcIfaceType cgb_resty diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs deleted file mode 100644 --- a/compiler/GHC/JS/Make.hs +++ /dev/null @@ -1,715 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr - ------------------------------------------------------------------------------ --- | --- Module : GHC.JS.Make --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Josh Meredith --- Stability : experimental --- --- --- * Domain and Purpose --- --- GHC.JS.Make defines helper functions to ease the creation of JavaScript --- ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL --- more ergonomic to program in, and make errors in the EDSL /look/ obvious --- because the EDSL is untyped. It is primarily concerned with injecting --- terms into the domain of the EDSL to construct JS programs in Haskell. --- --- * Strategy --- --- The strategy for this module comes straight from gentzen; where we have --- two types of helper functions. Functions which inject terms into the --- EDSL, and combinator functions which operate on terms in the EDSL to --- construct new terms in the EDSL. Crucially, missing from this module are --- corresponding /elimination/ or /destructing/ functions which would --- project information from the EDSL back to Haskell. See --- 'GHC.StgToJS.UnitUtils' and 'GHC.StgToJS.CoreUtils' for such functions. --- --- * /Introduction/ functions --- --- We define various primitive helpers which /introduce/ terms in the --- EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. Notice --- that the type of each of these functions have the domain @isSat a --- => a -> ...@; indicating that they each take something that /can/ --- be injected into the EDSL domain, and the range 'JExpr' or 'JStat'; --- indicating the corresponding value in the EDSL domain. Similarly --- this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr' --- injects values as a JS expression into the EDSL. 'ToSat' ensures --- that terms introduced into the EDSL carry identifier information so --- terms in the EDSL must have meaning. --- --- * /Combinator/ functions --- --- The rest of the module defines combinators which create terms in --- the EDSL from terms in the EDSL. Notable examples are '|=' and --- '||=', '|=' is sugar for 'AssignStat', it is a binding form that --- declares @foo = bar@ /assuming/ foo has been already declared. --- '||=' is more sugar on top of '|=', it is also a binding form that --- declares the LHS of '|=' before calling '|=' to bind a value, bar, --- to a variable foo. Other common examples are the 'if_' and 'math_' --- helpers such as 'math_cos'. --- --- * Consumers --- --- The entire JS backend consumes this module, e.g., the modules in --- GHC.StgToJS.\*. --- --- * Notation --- --- In this module we use @==>@ in docstrings to show the translation from --- the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo --- = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results --- in the JS code @var foo; foo = bar;@ when compiled. ------------------------------------------------------------------------------ -module GHC.JS.Make - ( -- * Injection Type classes - -- $classes - ToJExpr(..) - , ToStat(..) - -- * Introduction functions - -- $intro_funcs - , var - , jString - , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally - -- * Combinators - -- $combinators - , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) - , (.>.), (.>=.), (.<.), (.<=.) - , (.<<.), (.>>.), (.>>>.) - , (.|.), (.||.), (.&&.) - , if_, if10, if01, ifS, ifBlockS - , jwhenS - , app, appS, returnS - , loop, loopBlockS - , preIncrS, postIncrS - , preDecrS, postDecrS - , off8, off16, off32, off64 - , mask8, mask16 - , signExtend8, signExtend16 - , typeof - , returnStack, assignAllEqual, assignAll, assignAllReverseOrder - , declAssignAll - , nullStat, (.^) - , trace - -- ** Hash combinators - , jhEmpty - , jhSingle - , jhAdd - , jhFromList - -- * Literals - -- $literals - , null_ - , undefined_ - , false_ - , true_ - , zero_ - , one_ - , two_ - , three_ - -- ** Math functions - -- $math - , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, - math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, - math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround - -- * Statement helpers - , decl - -- * Miscellaneous - -- $misc - , allocData, allocClsA - , dataFieldName, dataFieldNames - ) -where - -import GHC.Prelude hiding ((.|.)) - -import GHC.JS.Syntax - -import Control.Arrow ((***)) - -import Data.Array -import qualified Data.Map as M -import qualified Data.List as List - -import GHC.Utils.Outputable (Outputable (..)) -import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Utils.Panic -import GHC.Utils.Misc -import GHC.Types.Unique.Map - --------------------------------------------------------------------------------- --- Type Classes --------------------------------------------------------------------------------- --- $classes --- The 'ToJExpr' class handles injection of of things into the EDSL as a JS --- expression - --- | Things that can be marshalled into javascript values. --- Instantiate for any necessary data structures. -class ToJExpr a where - toJExpr :: a -> JExpr - toJExprFromList :: [a] -> JExpr - toJExprFromList = ValExpr . JList . map toJExpr - -instance ToJExpr a => ToJExpr [a] where - toJExpr = toJExprFromList - -instance ToJExpr JExpr where - toJExpr = id - -instance ToJExpr () where - toJExpr _ = ValExpr $ JList [] - -instance ToJExpr Bool where - toJExpr True = var "true" - toJExpr False = var "false" - -instance ToJExpr JVal where - toJExpr = ValExpr - -instance ToJExpr a => ToJExpr (UniqMap FastString a) where - toJExpr = ValExpr . JHash . mapUniqMap toJExpr - -instance ToJExpr a => ToJExpr (M.Map String a) where - toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList - -instance ToJExpr Double where - toJExpr = ValExpr . JDouble . SaneDouble - -instance ToJExpr Int where - toJExpr = ValExpr . JInt . fromIntegral - -instance ToJExpr Integer where - toJExpr = ValExpr . JInt - -instance ToJExpr Char where - toJExpr = ValExpr . JStr . mkFastString . (:[]) - toJExprFromList = ValExpr . JStr . mkFastString --- where escQuotes = tailDef "" . initDef "" . show - -instance ToJExpr Ident where - toJExpr = ValExpr . JVar - -instance ToJExpr FastString where - toJExpr = ValExpr . JStr - -instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where - toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] - -instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where - toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c] - -instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where - toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d] -instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where - toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e] -instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where - toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] - - --- | The 'ToStat' class handles injection of of things into the EDSL as a JS --- statement. This ends up being polymorphic sugar for JS blocks, see helper --- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data --- structures. -class ToStat a where - toStat :: a -> JStat - -instance ToStat JStat where - toStat = id - -instance ToStat [JStat] where - toStat = BlockStat - -instance ToStat JExpr where - toStat = expr2stat - -instance ToStat [JExpr] where - toStat = BlockStat . map expr2stat - --------------------------------------------------------------------------------- --- Introduction Functions --------------------------------------------------------------------------------- --- $intro_functions --- Introduction functions are functions that map values or terms in the Haskell --- domain to the JS EDSL domain - --- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr' --- expression. --- Usage: --- --- > jLam $ \x -> jVar x + one_ --- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x))) -jLam :: ToSat a => a -> JExpr -jLam f = ValExpr . UnsatVal . IS $ do - (block,is) <- runIdentSupply $ toSat_ f [] - return $ JFunc is block - --- | Introduce a new variable into scope for the duration --- of the enclosed expression. The result is a block statement. --- Usage: --- --- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@ -jVar :: ToSat a => a -> JStat -jVar f = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let addDecls (BlockStat ss) = - BlockStat $ map decl is ++ ss - addDecls x = x - return $ addDecls block - --- | Create a 'for in' statement. --- Usage: --- --- @jForIn {expression} $ \x -> {block involving x}@ -jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat -jForIn e f = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let i = List.head is - return $ decl i `mappend` ForInStat False i e block - --- | As with "jForIn" but creating a \"for each in\" statement. -jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat -jForEachIn e f = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let i = List.head is - return $ decl i `mappend` ForInStat True i e block - --- | As with "jForIn" but creating a \"for each in\" statement. -jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat -jTryCatchFinally s f s2 = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let i = List.head is - return $ TryStat s i block s2 - --- | construct a JS variable reference -var :: FastString -> JExpr -var = ValExpr . JVar . TxtI - --- | Convert a ShortText to a Javascript String -jString :: FastString -> JExpr -jString = toJExpr - --- | Create a 'for' statement -jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat -jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] - where b' = case toStat b of - BlockStat xs -> BlockStat $ xs ++ [after] - x -> BlockStat [x,after] - --- | construct a js declaration with the given identifier -decl :: Ident -> JStat -decl i = DeclStat i Nothing - --- | The empty JS HashMap -jhEmpty :: M.Map k JExpr -jhEmpty = M.empty - --- | A singleton JS HashMap -jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -jhSingle k v = jhAdd k v jhEmpty - --- | insert a key-value pair into a JS HashMap -jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr -jhAdd k v m = M.insert k (toJExpr v) m - --- | Construct a JS HashMap from a list of key-value pairs -jhFromList :: [(FastString, JExpr)] -> JVal -jhFromList = JHash . listToUniqMap - --- | The empty JS statement -nullStat :: JStat -nullStat = BlockStat [] - - --------------------------------------------------------------------------------- --- Combinators --------------------------------------------------------------------------------- --- $combinators --- Combinators operate on terms in the JS EDSL domain to create new terms in the --- EDSL domain. - --- | JS infix Equality operators -(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr -(.==.) = InfixExpr EqOp -(.===.) = InfixExpr StrictEqOp -(.!=.) = InfixExpr NeqOp -(.!==.) = InfixExpr StrictNeqOp - -infixl 6 .==., .===., .!=., .!==. - --- | JS infix Ord operators -(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr -(.>.) = InfixExpr GtOp -(.>=.) = InfixExpr GeOp -(.<.) = InfixExpr LtOp -(.<=.) = InfixExpr LeOp - -infixl 7 .>., .>=., .<., .<=. - --- | JS infix bit operators -(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr -(.|.) = InfixExpr BOrOp -(.||.) = InfixExpr LOrOp -(.&&.) = InfixExpr LAndOp - -infixl 8 .||., .&&. - --- | JS infix bit shift operators -(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr -(.<<.) = InfixExpr LeftShiftOp -(.>>.) = InfixExpr RightShiftOp -(.>>>.) = InfixExpr ZRightShiftOp - -infixl 9 .<<., .>>., .>>>. - --- | Given a 'JExpr', return the its type. -typeof :: JExpr -> JExpr -typeof = UOpExpr TypeofOp - --- | JS if-expression --- --- > if_ e1 e2 e3 ==> e1 ? e2 : e3 -if_ :: JExpr -> JExpr -> JExpr -> JExpr -if_ e1 e2 e3 = IfExpr e1 e2 e3 - --- | If-expression which returns statements, see related 'ifBlockS' --- --- > if e s1 s2 ==> if(e) { s1 } else { s2 } -ifS :: JExpr -> JStat -> JStat -> JStat -ifS e s1 s2 = IfStat e s1 s2 - --- | A when-statement as syntactic sugar via `ifS` --- --- > jwhenS cond block ==> if(cond) { block } else { } -jwhenS :: JExpr -> JStat -> JStat -jwhenS cond block = ifS cond block mempty - --- | If-expression which returns blocks --- --- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 } -ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat -ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) - --- | if-expression that returns 1 if condition <=> true, 0 otherwise --- --- > if10 e ==> e ? 1 : 0 -if10 :: JExpr -> JExpr -if10 e = IfExpr e one_ zero_ - --- | if-expression that returns 0 if condition <=> true, 1 otherwise --- --- > if01 e ==> e ? 0 : 1 -if01 :: JExpr -> JExpr -if01 e = IfExpr e zero_ one_ - --- | an expression application, see related 'appS' --- --- > app f xs ==> f(xs) -app :: FastString -> [JExpr] -> JExpr -app f xs = ApplExpr (var f) xs - --- | A statement application, see the expression form 'app' -appS :: FastString -> [JExpr] -> JStat -appS f xs = ApplStat (var f) xs - --- | Return a 'JExpr' -returnS :: JExpr -> JStat -returnS e = ReturnStat e - --- | "for" loop with increment at end of body -loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat -loop initial test body = jVar $ \i -> - mconcat [ i |= initial - , WhileStat False (test i) (body i) - ] - --- | "for" loop with increment at end of body -loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat -loopBlockS initial test body = jVar $ \i -> - mconcat [ i |= initial - , WhileStat False (test i) (mconcat (body i)) - ] - --- | Prefix-increment a 'JExpr' -preIncrS :: JExpr -> JStat -preIncrS x = UOpStat PreIncOp x - --- | Postfix-increment a 'JExpr' -postIncrS :: JExpr -> JStat -postIncrS x = UOpStat PostIncOp x - --- | Prefix-decrement a 'JExpr' -preDecrS :: JExpr -> JStat -preDecrS x = UOpStat PreDecOp x - --- | Postfix-decrement a 'JExpr' -postDecrS :: JExpr -> JStat -postDecrS x = UOpStat PostDecOp x - --- | Byte indexing of o with a 64-bit offset -off64 :: JExpr -> JExpr -> JExpr -off64 o i = Add o (i .<<. three_) - --- | Byte indexing of o with a 32-bit offset -off32 :: JExpr -> JExpr -> JExpr -off32 o i = Add o (i .<<. two_) - --- | Byte indexing of o with a 16-bit offset -off16 :: JExpr -> JExpr -> JExpr -off16 o i = Add o (i .<<. one_) - --- | Byte indexing of o with a 8-bit offset -off8 :: JExpr -> JExpr -> JExpr -off8 o i = Add o i - --- | a bit mask to retrieve the lower 8-bits -mask8 :: JExpr -> JExpr -mask8 x = BAnd x (Int 0xFF) - --- | a bit mask to retrieve the lower 16-bits -mask16 :: JExpr -> JExpr -mask16 x = BAnd x (Int 0xFFFF) - --- | Sign-extend/narrow a 8-bit value -signExtend8 :: JExpr -> JExpr -signExtend8 x = (BAnd x (Int 0x7F )) `Sub` (BAnd x (Int 0x80)) - --- | Sign-extend/narrow a 16-bit value -signExtend16 :: JExpr -> JExpr -signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000)) - --- | Select a property 'prop', from and object 'obj' --- --- > obj .^ prop ==> obj.prop -(.^) :: JExpr -> FastString -> JExpr -obj .^ prop = SelExpr obj (TxtI prop) -infixl 8 .^ - --- | Assign a variable to an expression --- --- > foo |= expr ==> var foo = expr; -(|=) :: JExpr -> JExpr -> JStat -(|=) = AssignStat - --- | Declare a variable and then Assign the variable to an expression --- --- > foo |= expr ==> var foo; foo = expr; -(||=) :: Ident -> JExpr -> JStat -i ||= ex = DeclStat i (Just ex) - -infixl 2 ||=, |= - --- | return the expression at idx of obj --- --- > obj .! idx ==> obj[idx] -(.!) :: JExpr -> JExpr -> JExpr -(.!) = IdxExpr - -infixl 8 .! - -assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat -assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys) - -assignAll :: [JExpr] -> [JExpr] -> JStat -assignAll xs ys = mconcat (zipWith (|=) xs ys) - -assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat -assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) - -declAssignAll :: [Ident] -> [JExpr] -> JStat -declAssignAll xs ys = mconcat (zipWith (||=) xs ys) - -trace :: ToJExpr a => a -> JStat -trace ex = appS "h$log" [toJExpr ex] - - --------------------------------------------------------------------------------- --- Literals --------------------------------------------------------------------------------- --- $literals --- Literals in the JS EDSL are constants in the Haskell domain. These are useful --- helper values and never change - --- | The JS literal 'null' -null_ :: JExpr -null_ = var "null" - --- | The JS literal 0 -zero_ :: JExpr -zero_ = Int 0 - --- | The JS literal 1 -one_ :: JExpr -one_ = Int 1 - --- | The JS literal 2 -two_ :: JExpr -two_ = Int 2 - --- | The JS literal 3 -three_ :: JExpr -three_ = Int 3 - --- | The JS literal 'undefined' -undefined_ :: JExpr -undefined_ = var "undefined" - --- | The JS literal 'true' -true_ :: JExpr -true_ = var "true" - --- | The JS literal 'false' -false_ :: JExpr -false_ = var "false" - -returnStack :: JStat -returnStack = ReturnStat (ApplExpr (var "h$rs") []) - - --------------------------------------------------------------------------------- --- Math functions --------------------------------------------------------------------------------- --- $math --- Math functions in the EDSL are literals, with the exception of 'math_' which --- is the sole math introduction function. - -math :: JExpr -math = var "Math" - -math_ :: FastString -> [JExpr] -> JExpr -math_ op args = ApplExpr (math .^ op) args - -math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, - math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign, - math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround - :: [JExpr] -> JExpr -math_log = math_ "log" -math_sin = math_ "sin" -math_cos = math_ "cos" -math_tan = math_ "tan" -math_exp = math_ "exp" -math_acos = math_ "acos" -math_asin = math_ "asin" -math_atan = math_ "atan" -math_abs = math_ "abs" -math_pow = math_ "pow" -math_sign = math_ "sign" -math_sqrt = math_ "sqrt" -math_asinh = math_ "asinh" -math_acosh = math_ "acosh" -math_atanh = math_ "atanh" -math_sinh = math_ "sinh" -math_cosh = math_ "cosh" -math_tanh = math_ "tanh" -math_expm1 = math_ "expm1" -math_log1p = math_ "log1p" -math_fround = math_ "fround" - -instance Num JExpr where - x + y = InfixExpr AddOp x y - x - y = InfixExpr SubOp x y - x * y = InfixExpr MulOp x y - abs x = math_abs [x] - negate x = UOpExpr NegOp x - signum x = math_sign [x] - fromInteger x = ValExpr (JInt x) - -instance Fractional JExpr where - x / y = InfixExpr DivOp x y - fromRational x = ValExpr (JDouble (realToFrac x)) - - --------------------------------------------------------------------------------- --- Miscellaneous --------------------------------------------------------------------------------- --- $misc --- Everything else, - --- | Cache "dXXX" field names -dataFieldCache :: Array Int FastString -dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) - -nFieldCache :: Int -nFieldCache = 16384 - -dataFieldName :: Int -> FastString -dataFieldName i - | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i) - | otherwise = dataFieldCache ! i - -dataFieldNames :: [FastString] -dataFieldNames = fmap dataFieldName [1..nFieldCache] - - --- | Cache "h$dXXX" names -dataCache :: Array Int FastString -dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024]) - -allocData :: Int -> JExpr -allocData i = toJExpr (TxtI (dataCache ! i)) - --- | Cache "h$cXXX" names -clsCache :: Array Int FastString -clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024]) - -allocClsA :: Int -> JExpr -allocClsA i = toJExpr (TxtI (clsCache ! i)) - - --------------------------------------------------------------------------------- --- New Identifiers --------------------------------------------------------------------------------- - --- | The 'ToSat' class is heavily used in the Introduction function. It ensures --- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'. -class ToSat a where - toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident]) - -instance ToSat [JStat] where - toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) - -instance ToSat JStat where - toSat_ f vs = IS $ return $ (f, reverse vs) - -instance ToSat JExpr where - toSat_ f vs = IS $ return $ (toStat f, reverse vs) - -instance ToSat [JExpr] where - toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs) - -instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where - toSat_ f vs = IS $ do - x <- takeOneIdent - runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs) - --- | Convert A JS expression to a JS statement where applicable. This only --- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary --- expression; 'UOpExpr'. -expr2stat :: JExpr -> JStat -expr2stat (ApplExpr x y) = (ApplStat x y) -expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) -expr2stat (UOpExpr o x) = UOpStat o x -expr2stat _ = nullStat - -takeOneIdent :: State [Ident] Ident -takeOneIdent = do - xxs <- get - case xxs of - (x:xs) -> do - put xs - return x - _ -> error "takeOneIdent: empty list" - diff --git a/compiler/GHC/JS/Optimizer.hs b/compiler/GHC/JS/Optimizer.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/JS/Optimizer.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Optimizer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Optimizer is a shallow embedding of a peephole optimizer. That is, +-- this module defines transformations over the JavaScript IR in +-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or +-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The +-- optimizer is written in continuation passing style so optimizations +-- compose. +-- +-- * Architecture of the optimizer +-- +-- The design is that each optimization pattern matches on the head of a +-- block by pattern matching onto the head of the stream of nodes in the +-- JavaScript IR. If an optimization gets a successful match then it performs +-- whatever rewrite is necessary and then calls the 'loop' continuation. This +-- ensures that the result of the optimization is subject to the same +-- optimization, /and/ the rest of the optimizations. If there is no match +-- then the optimization should call the 'next' continuation to pass the +-- stream to the next optimization in the optimization chain. We then define +-- the last "optimization" to be @tailLoop@ which selects the next block of +-- code to optimize and begin the optimization pipeline again. +----------------------------------------------------------------------------- +module GHC.JS.Optimizer + ( jsOptimize + ) where + + +import Prelude + +import GHC.JS.Syntax + +import Control.Arrow + +{- +Note [Unsafe JavaScript optimizations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a number of optimizations that the JavaScript Backend performs that +are not sound with respect to arbritrary JavaScript. We still perform these +optimizations because we are not optimizing arbritrary javascript and under the +assumption that the JavaScript backend will not generate code that violates the +soundness of the optimizer. For example, the @deadCodeElim@ optimization removes +all statements that occur after a 'return' in JavaScript, however this is not +always sound because of hoisting, consider this program: + + function foo() { + var x = 2; + bar(); + return x; + + function bar() { + x = 10; + }} + + which is transformed to: + + function foo() { + var x = 2; + bar(); + return x; + }} + +The optimized form is clearly a program that goes wrong because `bar()` is no +longer defined. But the JavaScript backend will never generate this code, so as +long as that assumption holds we are safe to perform optimizations that would +normally be unsafe. +-} + + +-------------------------------------------------------------------------------- +-- Top level Driver +-------------------------------------------------------------------------------- +jsOptimize :: JStat -> JStat +jsOptimize = go + where + p_opt = jsOptimize + opt = jsOptimize' + e_opt = jExprOptimize + -- base case + go (BlockStat xs) = BlockStat (opt xs) + -- recursive cases + go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body) + go (ForInStat b i p body) = ForInStat b i p (p_opt body) + go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body) + go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body) + go (FuncStat i args body) = FuncStat i args (p_opt body) + go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e) + go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f) + go (LabelStat lbl s) = LabelStat lbl (p_opt s) + -- special case: drive the optimizer into expressions + go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs) + go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e) + go (ReturnStat e) = ReturnStat (e_opt e) + go (UOpStat op e) = UOpStat op (e_opt e) + go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args) + -- all else is terminal, we match on these to force a warning in the event + -- another constructor is added + go x@BreakStat{} = x + go x@ContinueStat{} = x + go x@DeclStat{} = x -- match on the nothing case + +jsOptimize' :: [JStat] -> [JStat] +jsOptimize' = runBlockOpt opts . single_pass_opts + where + opts :: BlockOpt + opts = safe_opts + <> unsafe_opts + <> tailLoop -- tailloop must be last, see module description + + unsafe_opts :: BlockOpt + unsafe_opts = mconcat [ deadCodeElim ] + + safe_opts :: BlockOpt + safe_opts = mconcat [ declareAssign, combineOps ] + + single_pass_opts :: BlockTrans + single_pass_opts = runBlockTrans sp_opts + + sp_opts = [flattenBlocks] + +-- | recur over a @JExpr@ and optimize the @JVal@s +jExprOptimize :: JExpr -> JExpr +-- the base case +jExprOptimize (ValExpr val) = ValExpr (jValOptimize val) +-- recursive cases +jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field +jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix) +jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp) +jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e) +jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args) +jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r) + +-- | drive optimizations to anonymous functions and over expressions +jValOptimize :: JVal -> JVal +-- base case +jValOptimize (JFunc args body) = JFunc args (jsOptimize body) +-- recursive cases +jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) +jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) +-- all else is terminal +jValOptimize x@JVar{} = x +jValOptimize x@JDouble{} = x +jValOptimize x@JInt{} = x +jValOptimize x@JStr{} = x +jValOptimize x@JRegEx{} = x + +-- | A block transformation is a function from a stream of syntax to another +-- stream +type BlockTrans = [JStat] -> [JStat] + +-- | A BlockOpt is a function that alters the stream, and a continuation that +-- represents the rest of the stream. The first @BlockTrans@ represents +-- restarting the optimizer after a change has happened. The second @BlockTrans@ +-- represents the rest of the continuation stream. +newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans) + +-- | To merge two BlockOpt we first run the left-hand side optimization and +-- capture the right-hand side in the continuation +instance Semigroup BlockOpt where + BlockOpt opt0 <> BlockOpt opt1 = BlockOpt + $ \loop next -> opt0 loop (opt1 loop next) + +instance Monoid BlockOpt where + -- don't loop, just finalize + mempty = BlockOpt $ \_loop next -> next + +-- | loop until a fixpoint is reached +runBlockOpt :: BlockOpt -> [JStat] -> [JStat] +runBlockOpt (BlockOpt opt) xs = recur xs + where recur = opt recur id + +runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat] +runBlockTrans opts = foldl (.) id opts + +-- | Perform all the optimizations on the tail of a block. +tailLoop :: BlockOpt +tailLoop = BlockOpt $ \loop next -> \case + [] -> next [] + -- this call to jsOptimize is required or else the optimizer will not + -- properly recur down JStat. See the 'deadCodeElim' test for examples which + -- were failing before this change + (x:xs) -> next (jsOptimize x : loop xs) + +-------------------------------------------------------------------------------- +-- Single Slot Optimizations +-------------------------------------------------------------------------------- + +{- | + Catch modify and assign operators: + case 1: + i = i + 1; ==> ++i; + case 2: + i = i - 1; ==> --i; + case 3: + i = i + n; ==> i += n; + case 4: + i = i - n; ==> i -= n; +-} +combineOps :: BlockOpt +combineOps = BlockOpt $ \loop next -> + \case + -- find a op pattern, and rerun the optimizer on its result unless there is + -- nothing to optimize, in which case call the next optimization + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op (ValExpr (JVar i')) e)) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- commutative cases + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op e (ValExpr (JVar i')))) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- general case, we had nothing to optimize in this case so call the next + -- optimization + xs -> next xs + + +-------------------------------------------------------------------------------- +-- Dual Slot Optimizations +-------------------------------------------------------------------------------- +-- | Catch 'var i; i = q;' ==> 'var i = q;' +declareAssign :: BlockOpt +declareAssign = BlockOpt $ + \loop next -> \case + ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) AssignOp v) + : xs + ) | i == i' -> loop (DeclStat i (Just v) : xs) + xs -> next xs + +-- | Eliminate all code after a return statement. This is a special case +-- optimization that doesn't need to loop. See Note [Unsafe JavaScript +-- optimizations] +deadCodeElim :: BlockOpt +deadCodeElim = BlockOpt $ + \_loop next -> \case + (x@ReturnStat{}:_) -> next [x] + xs -> next xs + +-- | remove nested blocks +flattenBlocks :: BlockTrans +flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys +flattenBlocks (x:xs) = x : flattenBlocks xs +flattenBlocks [] = [] diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs deleted file mode 100644 --- a/compiler/GHC/JS/Ppr.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BlockArguments #-} - --- For Outputable instances for JS syntax -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Pretty-printing JavaScript -module GHC.JS.Ppr - ( renderJs - , renderJs' - , renderPrefixJs - , renderPrefixJs' - , JsToDoc(..) - , defaultRenderJs - , RenderJs(..) - , jsToDoc - , pprStringLit - , flattenBlocks - , braceNest - , hangBrace - ) -where - -import GHC.Prelude - -import GHC.JS.Syntax -import GHC.JS.Transform - - -import Data.Char (isControl, ord) -import Data.List (sortOn) - -import Numeric(showHex) - -import GHC.Utils.Outputable (Outputable (..), docToSDoc) -import GHC.Utils.Ppr as PP -import GHC.Data.FastString -import GHC.Types.Unique.Map - -instance Outputable JExpr where - ppr = docToSDoc . renderJs - -instance Outputable JVal where - ppr = docToSDoc . renderJs - - -($$$) :: Doc -> Doc -> Doc -x $$$ y = nest 2 $ x $+$ y - --- | Render a syntax tree as a pretty-printable document --- (simply showing the resultant doc produces a nice, --- well formatted String). -renderJs :: (JsToDoc a, JMacro a) => a -> Doc -renderJs = renderJs' defaultRenderJs - -renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc -renderJs' r = jsToDocR r . jsSaturate Nothing - -data RenderJs = RenderJs - { renderJsS :: !(RenderJs -> JStat -> Doc) - , renderJsE :: !(RenderJs -> JExpr -> Doc) - , renderJsV :: !(RenderJs -> JVal -> Doc) - , renderJsI :: !(RenderJs -> Ident -> Doc) - } - -defaultRenderJs :: RenderJs -defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI - -jsToDoc :: JsToDoc a => a -> Doc -jsToDoc = jsToDocR defaultRenderJs - --- | Render a syntax tree as a pretty-printable document, using a given prefix --- to all generated names. Use this with distinct prefixes to ensure distinct --- generated names between independent calls to render(Prefix)Js. -renderPrefixJs :: (JsToDoc a, JMacro a) => FastString -> a -> Doc -renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx - -renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc -renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx) - -braceNest :: Doc -> Doc -braceNest x = char '{' <+> nest 2 x $$ char '}' - --- | Hang with braces: --- --- hdr { --- body --- } -hangBrace :: Doc -> Doc -> Doc -hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] - -class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc -instance JsToDoc JStat where jsToDocR r = renderJsS r r -instance JsToDoc JExpr where jsToDocR r = renderJsE r r -instance JsToDoc JVal where jsToDocR r = renderJsV r r -instance JsToDoc Ident where jsToDocR r = renderJsI r r -instance JsToDoc [JExpr] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) -instance JsToDoc [JStat] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) - -defRenderJsS :: RenderJs -> JStat -> Doc -defRenderJsS r = \case - IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond)) - (jsToDocR r x) - $$ mbElse - where mbElse | y == BlockStat [] = PP.empty - | otherwise = hangBrace (text "else") (jsToDocR r y) - DeclStat x Nothing -> text "var" <+> jsToDocR r x - DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e - WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b) - WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p) - UnsatBlock e -> jsToDocR r $ pseudoSaturate e - BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l - ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l - LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s - where - printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss - printBS x = jsToDocR r x - interSemi [x] = [jsToDocR r x] - interSemi [] = [] - interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs - - ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) - where txt | each = "for each" - | otherwise = "for" - SwitchStat e l d -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases - where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)] - cases = vcat l' - ReturnStat e -> text "return" <+> jsToDocR r e - ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) - TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally - where mbCatch | s1 == BlockStat [] = PP.empty - | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) - mbFinally | s2 == BlockStat [] = PP.empty - | otherwise = hangBrace (text "finally") (jsToDocR r s2) - AssignStat i x -> case x of - -- special treatment for functions, otherwise there is too much left padding - -- (more than the length of the expression assigned to). E.g. - -- - -- var long_variable_name = (function() - -- { - -- ... - -- }); - -- - ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x - UOpStat op x - | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x - | isPre op -> ftext (uOpText op) <> optParens r x - | otherwise -> optParens r x <> ftext (uOpText op) - BlockStat xs -> jsToDocR r (flattenBlocks xs) - -flattenBlocks :: [JStat] -> [JStat] -flattenBlocks = \case - BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] - -optParens :: RenderJs -> JExpr -> Doc -optParens r x = case x of - UOpExpr _ _ -> parens (jsToDocR r x) - _ -> jsToDocR r x - -defRenderJsE :: RenderJs -> JExpr -> Doc -defRenderJsE r = \case - ValExpr x -> jsToDocR r x - SelExpr x y -> jsToDocR r x <> char '.' <> jsToDocR r y - IdxExpr x y -> jsToDocR r x <> brackets (jsToDocR r y) - IfExpr x y z -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z) - InfixExpr op x y -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y] - UOpExpr op x - | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x - | isPre op -> ftext (uOpText op) <> optParens r x - | otherwise -> optParens r x <> ftext (uOpText op) - ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs) - UnsatExpr e -> jsToDocR r $ pseudoSaturate e - -defRenderJsV :: RenderJs -> JVal -> Doc -defRenderJsV r = \case - JVar i -> jsToDocR r i - JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs - JDouble (SaneDouble d) - | d < 0 || isNegativeZero d -> parens (double d) - | otherwise -> double d - JInt i - | i < 0 -> parens (integer i) - | otherwise -> integer i - JStr s -> pprStringLit s - JRegEx s -> hcat [char '/',ftext s, char '/'] - JHash m - | isNullUniqMap m -> text "{}" - | otherwise -> braceNest . hsep . punctuate comma . - map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y) - -- nonDetEltsUniqMap doesn't introduce non-determinism here - -- because we sort the elements lexically - $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m) - JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) - UnsatVal f -> jsToDocR r $ pseudoSaturate f - -defRenderJsI :: RenderJs -> Ident -> Doc -defRenderJsI _ (TxtI t) = ftext t - - -pprStringLit :: FastString -> Doc -pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] - -encodeJson :: FastString -> Doc -encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) - -encodeJsonChar :: Char -> Doc -encodeJsonChar = \case - '/' -> text "\\/" - '\b' -> text "\\b" - '\f' -> text "\\f" - '\n' -> text "\\n" - '\r' -> text "\\r" - '\t' -> text "\\t" - '"' -> text "\\\"" - '\\' -> text "\\\\" - c - | not (isControl c) && ord c <= 127 -> char c - | ord c <= 0xff -> hexxs "\\x" 2 (ord c) - | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) - | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair - in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> - hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) - where hexxs prefix pad cp = - let h = showHex cp "" - in text (prefix ++ replicate (pad - length h) '0' ++ h) - -uOpText :: JUOp -> FastString -uOpText = \case - NotOp -> "!" - BNotOp -> "~" - NegOp -> "-" - PlusOp -> "+" - NewOp -> "new" - TypeofOp -> "typeof" - DeleteOp -> "delete" - YieldOp -> "yield" - VoidOp -> "void" - PreIncOp -> "++" - PostIncOp -> "++" - PreDecOp -> "--" - PostDecOp -> "--" - -opText :: JOp -> FastString -opText = \case - EqOp -> "==" - StrictEqOp -> "===" - NeqOp -> "!=" - StrictNeqOp -> "!==" - GtOp -> ">" - GeOp -> ">=" - LtOp -> "<" - LeOp -> "<=" - AddOp -> "+" - SubOp -> "-" - MulOp -> "*" - DivOp -> "/" - ModOp -> "%" - LeftShiftOp -> "<<" - RightShiftOp -> ">>" - ZRightShiftOp -> ">>>" - BAndOp -> "&" - BOrOp -> "|" - BXorOp -> "^" - LAndOp -> "&&" - LOrOp -> "||" - InstanceofOp -> "instanceof" - InOp -> "in" - - -isPre :: JUOp -> Bool -isPre = \case - PostIncOp -> False - PostDecOp -> False - _ -> True - -isAlphaOp :: JUOp -> Bool -isAlphaOp = \case - NewOp -> True - TypeofOp -> True - DeleteOp -> True - YieldOp -> True - VoidOp -> True - _ -> False diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs deleted file mode 100644 --- a/compiler/GHC/JS/Syntax.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE PatternSynonyms #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.JS.Syntax --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Josh Meredith --- Stability : experimental --- --- --- * Domain and Purpose --- --- GHC.JS.Syntax defines the Syntax for the JS backend in GHC. It comports --- with the [ECMA-262](https://tc39.es/ecma262/) although not every --- production rule of the standard is represented. Code in this module is a --- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 --- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's --- constraints. --- --- --- * Strategy --- --- Nothing fancy in this module, this is a classic deeply embeded AST for --- JS. We define numerous ADTs and pattern synonyms to make pattern matching --- and constructing ASTs easier. --- --- --- * Consumers --- --- The entire JS backend consumes this module, e.g., the modules in --- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides --- helper functions that use the deeply embedded DSL defined in this module --- to provide some of the benefits of a shallow embedding. ------------------------------------------------------------------------------ -module GHC.JS.Syntax - ( -- * Deeply embedded JS datatypes - JStat(..) - , JExpr(..) - , JVal(..) - , JOp(..) - , JUOp(..) - , Ident(..) - , identFS - , JsLabel - -- * pattern synonyms over JS operators - , pattern New - , pattern Not - , pattern Negate - , pattern Add - , pattern Sub - , pattern Mul - , pattern Div - , pattern Mod - , pattern BOr - , pattern BAnd - , pattern BXor - , pattern BNot - , pattern LOr - , pattern LAnd - , pattern Int - , pattern String - , pattern PreInc - , pattern PostInc - , pattern PreDec - , pattern PostDec - -- * Ident supply - , IdentSupply(..) - , newIdentSupply - , pseudoSaturate - -- * Utility - , SaneDouble(..) - ) where - -import GHC.Prelude - -import Control.DeepSeq - -import Data.Function -import Data.Data -import Data.Word -import qualified Data.Semigroup as Semigroup - -import GHC.Generics - -import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Types.Unique -import GHC.Types.Unique.Map - --- | A supply of identifiers, possibly empty -newtype IdentSupply a - = IS {runIdentSupply :: State [Ident] a} - deriving Typeable - -instance NFData (IdentSupply a) where rnf IS{} = () - -inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b -inIdentSupply f x = IS $ f (runIdentSupply x) - -instance Functor IdentSupply where - fmap f x = inIdentSupply (fmap f) x - -newIdentSupply :: Maybe FastString -> [Ident] -newIdentSupply Nothing = newIdentSupply (Just "jmId") -newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) - | x <- [(0::Word64)..] - ] - --- | Given a Pseudo-saturate a value with garbage @<>@ identifiers. -pseudoSaturate :: IdentSupply a -> a -pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<>") - -instance Eq a => Eq (IdentSupply a) where - (==) = (==) `on` pseudoSaturate -instance Ord a => Ord (IdentSupply a) where - compare = compare `on` pseudoSaturate -instance Show a => Show (IdentSupply a) where - show x = "(" ++ show (pseudoSaturate x) ++ ")" - - --------------------------------------------------------------------------------- --- Statements --------------------------------------------------------------------------------- --- | JavaScript statements, see the [ECMA262 --- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) --- for details -data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If - | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True - | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True - | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch - | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat JUOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' - | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JsLabel) -- ^ Break - | ContinueStat (Maybe JsLabel) -- ^ Continue - deriving (Eq, Typeable, Generic) - --- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of --- course 'LabelStat' -type JsLabel = LexicalFastString - -instance Semigroup JStat where - (<>) = appendJStat - -instance Monoid JStat where - mempty = BlockStat [] - --- | Append a statement to another statement. 'appendJStat' only returns a --- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty --- 'BlockStat'. That is: --- > (BlockStat [] , y ) = y --- > (x , BlockStat []) = x -appendJStat :: JStat -> JStat -> JStat -appendJStat mx my = case (mx,my) of - (BlockStat [] , y ) -> y - (x , BlockStat []) -> x - (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys - (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $ xs : ys - (xs , ys ) -> BlockStat [xs,ys] - - --------------------------------------------------------------------------------- --- Expressions --------------------------------------------------------------------------------- --- | JavaScript Expressions -data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' - | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' - -- pattern synonyms - | UOpExpr JUOp JExpr -- ^ Unary Expressions - | IfExpr JExpr JExpr JExpr -- ^ If-expression - | ApplExpr JExpr [JExpr] -- ^ Application - | UnsatExpr (IdentSupply JExpr) -- ^ An /Unsaturated/ expression. - -- See 'pseudoSaturate' - deriving (Eq, Typeable, Generic) - --- * Useful pattern synonyms to ease programming with the deeply embedded JS --- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and --- for convienience. In addition we include a string wrapper for JS string --- and Integer literals. - --- | pattern synonym for a unary operator new -pattern New :: JExpr -> JExpr -pattern New x = UOpExpr NewOp x - --- | pattern synonym for prefix increment @++x@ -pattern PreInc :: JExpr -> JExpr -pattern PreInc x = UOpExpr PreIncOp x - --- | pattern synonym for postfix increment @x++@ -pattern PostInc :: JExpr -> JExpr -pattern PostInc x = UOpExpr PostIncOp x - --- | pattern synonym for prefix decrement @--x@ -pattern PreDec :: JExpr -> JExpr -pattern PreDec x = UOpExpr PreDecOp x - --- | pattern synonym for postfix decrement @--x@ -pattern PostDec :: JExpr -> JExpr -pattern PostDec x = UOpExpr PostDecOp x - --- | pattern synonym for logical not @!@ -pattern Not :: JExpr -> JExpr -pattern Not x = UOpExpr NotOp x - --- | pattern synonym for unary negation @-@ -pattern Negate :: JExpr -> JExpr -pattern Negate x = UOpExpr NegOp x - --- | pattern synonym for addition @+@ -pattern Add :: JExpr -> JExpr -> JExpr -pattern Add x y = InfixExpr AddOp x y - --- | pattern synonym for subtraction @-@ -pattern Sub :: JExpr -> JExpr -> JExpr -pattern Sub x y = InfixExpr SubOp x y - --- | pattern synonym for multiplication @*@ -pattern Mul :: JExpr -> JExpr -> JExpr -pattern Mul x y = InfixExpr MulOp x y - --- | pattern synonym for division @*@ -pattern Div :: JExpr -> JExpr -> JExpr -pattern Div x y = InfixExpr DivOp x y - --- | pattern synonym for remainder @%@ -pattern Mod :: JExpr -> JExpr -> JExpr -pattern Mod x y = InfixExpr ModOp x y - --- | pattern synonym for Bitwise Or @|@ -pattern BOr :: JExpr -> JExpr -> JExpr -pattern BOr x y = InfixExpr BOrOp x y - --- | pattern synonym for Bitwise And @&@ -pattern BAnd :: JExpr -> JExpr -> JExpr -pattern BAnd x y = InfixExpr BAndOp x y - --- | pattern synonym for Bitwise XOr @^@ -pattern BXor :: JExpr -> JExpr -> JExpr -pattern BXor x y = InfixExpr BXorOp x y - --- | pattern synonym for Bitwise Not @~@ -pattern BNot :: JExpr -> JExpr -pattern BNot x = UOpExpr BNotOp x - --- | pattern synonym for logical Or @||@ -pattern LOr :: JExpr -> JExpr -> JExpr -pattern LOr x y = InfixExpr LOrOp x y - --- | pattern synonym for logical And @&&@ -pattern LAnd :: JExpr -> JExpr -> JExpr -pattern LAnd x y = InfixExpr LAndOp x y - - --- | pattern synonym to create integer values -pattern Int :: Integer -> JExpr -pattern Int x = ValExpr (JInt x) - --- | pattern synonym to create string values -pattern String :: FastString -> JExpr -pattern String x = ValExpr (JStr x) - - --------------------------------------------------------------------------------- --- Values --------------------------------------------------------------------------------- --- | JavaScript values -data JVal - = JVar Ident -- ^ A variable reference - | JList [JExpr] -- ^ A JavaScript list, or what JS - -- calls an Array - | JDouble SaneDouble -- ^ A Double - | JInt Integer -- ^ A BigInt - | JStr FastString -- ^ A String - | JRegEx FastString -- ^ A Regex - | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ - | JFunc [Ident] JStat -- ^ A function - | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' - deriving (Eq, Typeable, Generic) - --------------------------------------------------------------------------------- --- Operators --------------------------------------------------------------------------------- --- | JS Binary Operators. We do not deeply embed the comma operator and the --- assignment operators -data JOp - = EqOp -- ^ Equality: `==` - | StrictEqOp -- ^ Strict Equality: `===` - | NeqOp -- ^ InEquality: `!=` - | StrictNeqOp -- ^ Strict InEquality `!==` - | GtOp -- ^ Greater Than: `>` - | GeOp -- ^ Greater Than or Equal: `>=` - | LtOp -- ^ Less Than: < - | LeOp -- ^ Less Than or Equal: <= - | AddOp -- ^ Addition: + - | SubOp -- ^ Subtraction: - - | MulOp -- ^ Multiplication \* - | DivOp -- ^ Division: \/ - | ModOp -- ^ Remainder: % - | LeftShiftOp -- ^ Left Shift: \<\< - | RightShiftOp -- ^ Right Shift: \>\> - | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> - | BAndOp -- ^ Bitwise And: & - | BOrOp -- ^ Bitwise Or: | - | BXorOp -- ^ Bitwise XOr: ^ - | LAndOp -- ^ Logical And: && - | LOrOp -- ^ Logical Or: || - | InstanceofOp -- ^ @instanceof@ - | InOp -- ^ @in@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) - -instance NFData JOp - --- | JS Unary Operators -data JUOp - = NotOp -- ^ Logical Not: @!@ - | BNotOp -- ^ Bitwise Not: @~@ - | NegOp -- ^ Negation: @-@ - | PlusOp -- ^ Unary Plus: @+x@ - | NewOp -- ^ new x - | TypeofOp -- ^ typeof x - | DeleteOp -- ^ delete x - | YieldOp -- ^ yield x - | VoidOp -- ^ void x - | PreIncOp -- ^ Prefix Increment: @++x@ - | PostIncOp -- ^ Postfix Increment: @x++@ - | PreDecOp -- ^ Prefix Decrement: @--x@ - | PostDecOp -- ^ Postfix Decrement: @x--@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) - -instance NFData JUOp - --- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' --- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on --- Sane-ness -newtype SaneDouble = SaneDouble - { unSaneDouble :: Double - } - deriving (Data, Typeable, Fractional, Num, Generic, NFData) - -instance Eq SaneDouble where - (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) - -instance Ord SaneDouble where - compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) - where fromNaN z | isNaN z = Nothing - | otherwise = Just z - -instance Show SaneDouble where - show (SaneDouble x) = show x - - --------------------------------------------------------------------------------- --- Identifiers --------------------------------------------------------------------------------- --- We use FastString for identifiers in JS backend - --- | A newtype wrapper around 'FastString' for JS identifiers. -newtype Ident = TxtI { itxt :: FastString } - deriving stock (Show, Eq) - deriving newtype (Uniquable) - -identFS :: Ident -> FastString -identFS = \case - TxtI fs -> fs diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs deleted file mode 100644 --- a/compiler/GHC/JS/Transform.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BlockArguments #-} - -module GHC.JS.Transform - ( mapIdent - , mapStatIdent - , mapExprIdent - , identsS - , identsV - , identsE - -- * Saturation - , jsSaturate - -- * Generic traversal (via compos) - , JMacro(..) - , JMGadt(..) - , Compos(..) - , composOp - , composOpM - , composOpM_ - , composOpFold - ) -where - -import GHC.Prelude - -import GHC.JS.Syntax - -import Data.Functor.Identity -import Control.Monad -import Data.Bifunctor - -import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Types.Unique.Map - -mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr -mapExprIdent f = fst (mapIdent f) - -mapStatIdent :: (Ident -> JExpr) -> JStat -> JStat -mapStatIdent f = snd (mapIdent f) - --- | Map on every variable ident -mapIdent :: (Ident -> JExpr) -> (JExpr -> JExpr, JStat -> JStat) -mapIdent f = (map_expr, map_stat) - where - map_expr = \case - ValExpr v -> map_val v - SelExpr e i -> SelExpr (map_expr e) i - IdxExpr e1 e2 -> IdxExpr (map_expr e1) (map_expr e2) - InfixExpr o e1 e2 -> InfixExpr o (map_expr e1) (map_expr e2) - UOpExpr o e -> UOpExpr o (map_expr e) - IfExpr e1 e2 e3 -> IfExpr (map_expr e1) (map_expr e2) (map_expr e3) - ApplExpr e es -> ApplExpr (map_expr e) (fmap map_expr es) - UnsatExpr me -> UnsatExpr (fmap map_expr me) - - map_val v = case v of - JVar i -> f i - JList es -> ValExpr $ JList (fmap map_expr es) - JDouble{} -> ValExpr $ v - JInt{} -> ValExpr $ v - JStr{} -> ValExpr $ v - JRegEx{} -> ValExpr $ v - JHash me -> ValExpr $ JHash (fmap map_expr me) - JFunc is s -> ValExpr $ JFunc is (map_stat s) - UnsatVal v2 -> ValExpr $ UnsatVal v2 - - map_stat s = case s of - DeclStat i e -> DeclStat i (fmap map_expr e) - ReturnStat e -> ReturnStat (map_expr e) - IfStat e s1 s2 -> IfStat (map_expr e) (map_stat s1) (map_stat s2) - WhileStat b e s2 -> WhileStat b (map_expr e) (map_stat s2) - ForInStat b i e s2 -> ForInStat b i (map_expr e) (map_stat s2) - SwitchStat e les s2 -> SwitchStat (map_expr e) (fmap (bimap map_expr map_stat) les) (map_stat s2) - TryStat s2 i s3 s4 -> TryStat (map_stat s2) i (map_stat s3) (map_stat s4) - BlockStat ls -> BlockStat (fmap map_stat ls) - ApplStat e es -> ApplStat (map_expr e) (fmap map_expr es) - UOpStat o e -> UOpStat o (map_expr e) - AssignStat e1 e2 -> AssignStat (map_expr e1) (map_expr e2) - UnsatBlock ms -> UnsatBlock (fmap map_stat ms) - LabelStat l s2 -> LabelStat l (map_stat s2) - BreakStat{} -> s - ContinueStat{} -> s - -{-# INLINE identsS #-} -identsS :: JStat -> [Ident] -identsS = \case - DeclStat i e -> [i] ++ maybe [] identsE e - ReturnStat e -> identsE e - IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 - WhileStat _ e s -> identsE e ++ identsS s - ForInStat _ i e s -> [i] ++ identsE e ++ identsS s - SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s - where traverseCase (e,s) = identsE e ++ identsS s - TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 - BlockStat xs -> concatMap identsS xs - ApplStat e es -> identsE e ++ concatMap identsE es - UOpStat _op e -> identsE e - AssignStat e1 e2 -> identsE e1 ++ identsE e2 - UnsatBlock{} -> error "identsS: UnsatBlock" - LabelStat _l s -> identsS s - BreakStat{} -> [] - ContinueStat{} -> [] - -{-# INLINE identsE #-} -identsE :: JExpr -> [Ident] -identsE = \case - ValExpr v -> identsV v - SelExpr e _i -> identsE e -- do not rename properties - IdxExpr e1 e2 -> identsE e1 ++ identsE e2 - InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 - UOpExpr _ e -> identsE e - IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 - ApplExpr e es -> identsE e ++ concatMap identsE es - UnsatExpr{} -> error "identsE: UnsatExpr" - -{-# INLINE identsV #-} -identsV :: JVal -> [Ident] -identsV = \case - JVar i -> [i] - JList xs -> concatMap identsE xs - JDouble{} -> [] - JInt{} -> [] - JStr{} -> [] - JRegEx{} -> [] - JHash m -> concatMap (identsE . snd) (nonDetEltsUniqMap m) - JFunc args s -> args ++ identsS s - UnsatVal{} -> error "identsV: UnsatVal" - - -{-------------------------------------------------------------------- - Compos ---------------------------------------------------------------------} --- | Compos and ops for generic traversal as defined over --- the JMacro ADT. - --- | Utility class to coerce the ADT into a regular structure. - -class JMacro a where - jtoGADT :: a -> JMGadt a - jfromGADT :: JMGadt a -> a - -instance JMacro Ident where - jtoGADT = JMGId - jfromGADT (JMGId x) = x - -instance JMacro JStat where - jtoGADT = JMGStat - jfromGADT (JMGStat x) = x - -instance JMacro JExpr where - jtoGADT = JMGExpr - jfromGADT (JMGExpr x) = x - -instance JMacro JVal where - jtoGADT = JMGVal - jfromGADT (JMGVal x) = x - --- | Union type to allow regular traversal by compos. -data JMGadt a where - JMGId :: Ident -> JMGadt Ident - JMGStat :: JStat -> JMGadt JStat - JMGExpr :: JExpr -> JMGadt JExpr - JMGVal :: JVal -> JMGadt JVal - -composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b -composOp f = runIdentity . composOpM (Identity . f) - -composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b) -composOpM = compos return ap - -composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m () -composOpM_ = composOpFold (return ()) (>>) - -composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b -composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) - -newtype C b a = C { unC :: b } - -class Compos t where - compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) - -> (forall a. t a -> m (t a)) -> t c -> m (t c) - -instance Compos JMGadt where - compos = jmcompos - -jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c) -jmcompos ret app f' v = - case v of - JMGId _ -> ret v - JMGStat v' -> ret JMGStat `app` case v' of - DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e - ReturnStat i -> ret ReturnStat `app` f i - IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' - WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s - ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s - SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d - where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l - BlockStat xs -> ret BlockStat `app` mapM' f xs - ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs - TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2 - UOpStat o e -> ret (UOpStat o) `app` f e - AssignStat e e' -> ret AssignStat `app` f e `app` f e' - UnsatBlock _ -> ret v' - ContinueStat l -> ret (ContinueStat l) - BreakStat l -> ret (BreakStat l) - LabelStat l s -> ret (LabelStat l) `app` f s - JMGExpr v' -> ret JMGExpr `app` case v' of - ValExpr e -> ret ValExpr `app` f e - SelExpr e e' -> ret SelExpr `app` f e `app` f e' - IdxExpr e e' -> ret IdxExpr `app` f e `app` f e' - InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e' - UOpExpr o e -> ret (UOpExpr o) `app` f e - IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e'' - ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs - UnsatExpr _ -> ret v' - JMGVal v' -> ret JMGVal `app` case v' of - JVar i -> ret JVar `app` f i - JList xs -> ret JList `app` mapM' f xs - JDouble _ -> ret v' - JInt _ -> ret v' - JStr _ -> ret v' - JRegEx _ -> ret v' - JHash m -> ret JHash `app` m' - -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the - -- elements are treated independently before being re-added to a UniqMap - where (ls, vs) = unzip (nonDetEltsUniqMap m) - m' = ret (listToUniqMap . zip ls) `app` mapM' f vs - JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s - UnsatVal _ -> ret v' - - where - mapM' :: forall a. (a -> m a) -> [a] -> m [a] - mapM' g = foldr (app . app (ret (:)) . g) (ret []) - mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a) - mapMaybeM' g = \case - Nothing -> ret Nothing - Just a -> app (ret Just) (g a) - f :: forall b. JMacro b => b -> m b - f x = ret jfromGADT `app` f' (jtoGADT x) - -{-------------------------------------------------------------------- - Saturation ---------------------------------------------------------------------} - --- | Given an optional prefix, fills in all free variable names with a supply --- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v diff --git a/compiler/GHC/Linker/Deps.hs b/compiler/GHC/Linker/Deps.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Linker/Deps.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module GHC.Linker.Deps + ( LinkDepsOpts (..) + , LinkDeps (..) + , getLinkDeps + ) +where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Runtime.Interpreter + +import GHC.Linker.Types + +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Error + +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.WholeCoreBindings +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Graph +import GHC.Unit.Home.ModInfo + +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr + +import GHC.Utils.Misc +import GHC.Unit.Home +import GHC.Data.Maybe + +import Control.Monad +import Control.Applicative + +import qualified Data.Set as Set +import qualified Data.Map as M +import Data.List (isSuffixOf) +import Data.Either + +import System.FilePath +import System.Directory + + +data LinkDepsOpts = LinkDepsOpts + { ldObjSuffix :: !String -- ^ Suffix of .o files + , ldOneShotMode :: !Bool -- ^ Is the driver in one-shot mode? + , ldModuleGraph :: !ModuleGraph -- ^ Module graph + , ldUnitEnv :: !UnitEnv -- ^ Unit environment + , ldPprOpts :: !SDocContext -- ^ Rendering options for error messages + , ldFinderCache :: !FinderCache -- ^ Finder cache + , ldFinderOpts :: !FinderOpts -- ^ Finder options + , ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects + , ldMsgOpts :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics + , ldWays :: !Ways -- ^ Enabled ways + , ldLoadIface :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface) + -- ^ Interface loader function + } + +data LinkDeps = LinkDeps + { ldNeededLinkables :: [Linkable] + , ldAllLinkables :: [Linkable] + , ldUnits :: [UnitId] + , ldNeededUnits :: UniqDSet UnitId + } + +-- | Find all the packages and linkables that a set of modules depends on +-- +-- Return the module and package dependencies for the needed modules. +-- See Note [Object File Dependencies] +-- +-- Fails with an IO exception if it can't find enough files +-- +getLinkDeps + :: LinkDepsOpts + -> Interp + -> LoaderState + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO LinkDeps -- ... then link these first +getLinkDeps opts interp pls span mods = do + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay opts interp span + + get_link_deps opts pls maybe_normal_osuf span mods + + +get_link_deps + :: LinkDepsOpts + -> LoaderState + -> Maybe FilePath -- replace object suffixes? + -> SrcSpan + -> [Module] + -> IO LinkDeps +get_link_deps opts pls maybe_normal_osuf span mods = do + -- 1. Find the dependent home-pkg-modules/packages from each iface + -- (omitting modules from the interactive package, which is already linked) + (mods_s, pkgs_s) <- + -- Why two code paths here? There is a significant amount of repeated work + -- performed calculating transitive dependencies + -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests) + if ldOneShotMode opts + then follow_deps (filterOut isInteractiveModule mods) + emptyUniqDSet emptyUniqDSet; + else do + (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods + return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs)) + + let + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + (mods_needed, links_got) = partitionEithers (map split_mods mods_s) + pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls + + split_mods mod = + let is_linked = lookupModuleEnv (objs_loaded pls) mod + <|> lookupModuleEnv (bcos_loaded pls) mod + in case is_linked of + Just linkable -> Right linkable + Nothing -> Left mod + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable + lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed + + return $ LinkDeps + { ldNeededLinkables = lnks_needed + , ldAllLinkables = links_got ++ lnks_needed + , ldUnits = pkgs_needed + , ldNeededUnits = pkgs_s + } + where + mod_graph = ldModuleGraph opts + unit_env = ldUnitEnv opts + + -- This code is used in `--make` mode to calculate the home package and unit dependencies + -- for a set of modules. + -- + -- It is significantly more efficient to use the shared transitive dependency + -- calculation than to compute the transitive dependency set in the same manner as oneShot mode. + + -- It is also a matter of correctness to use the module graph so that dependencies between home units + -- is resolved correctly. + make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop found [] = found + make_deps_loop found@(found_units, found_mods) (nk:nexts) + | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts + | otherwise = + case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of + Just trans_deps -> + let deps = Set.insert (NodeKey_Module nk) trans_deps + -- See #936 and the ghci.prog007 test for why we have to continue traversing through + -- boot modules. + todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps] + in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts) + Nothing -> + let (ModNodeKeyWithUid _ uid) = nk + in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts + + mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) + (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) + + all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] + + get_mod_info (ModNodeKeyWithUid gwib uid) = + case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of + Just hmi -> + let iface = (hm_iface hmi) + mmod = case mi_hsc_src iface of + HsBootFile -> link_boot_mod_error (mi_module iface) + _ -> return $ Just (mi_module iface) + + in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod + Nothing -> throwProgramError opts $ + text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid + + + -- This code is used in one-shot mode to traverse downwards through the HPT + -- to find all link dependencies. + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqDSet Module -- accum. module dependencies + -> UniqDSet UnitId -- accum. package dependencies + -> IO ([Module], UniqDSet UnitId) -- result + follow_deps [] acc_mods acc_pkgs + = return (uniqDSetToList acc_mods, acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs + = do + mb_iface <- ldLoadIface opts msg mod + iface <- case mb_iface of + Failed err -> throwProgramError opts $ + missingInterfaceErrorDiagnostic (ldMsgOpts opts) err + Succeeded iface -> return iface + + when (mi_boot iface == IsBoot) $ link_boot_mod_error mod + + let + pkg = moduleUnit mod + deps = mi_deps iface + + pkg_deps = dep_direct_pkgs deps + (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $ + \case + (_, GWIB m IsBoot) -> Left m + (_, GWIB m NotBoot) -> Right m + + mod_deps' = case ue_homeUnit unit_env of + Nothing -> [] + Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps)) + acc_mods' = case ue_homeUnit unit_env of + Nothing -> acc_mods + Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) + + case ue_homeUnit unit_env of + Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) + acc_mods' acc_pkgs' + _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" + + + + link_boot_mod_error :: Module -> IO a + link_boot_mod_error mod = throwProgramError opts $ + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module" + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith opts span $ + text "cannot find object file for module " <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = text "while linking an interpreted expression" + + + -- See Note [Using Byte Code rather than Object Code for Template Haskell] + homeModLinkable :: HomeModInfo -> Maybe Linkable + homeModLinkable hmi = + if ldUseByteCode opts + then homeModInfoByteCode hmi <|> homeModInfoObject hmi + else homeModInfoObject hmi <|> homeModInfoByteCode hmi + + get_linkable osuf mod -- A home-package module + | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env) + = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + case ue_homeUnit unit_env of + Nothing -> no_obj mod + Just home_unit -> do + + let fc = ldFinderCache opts + let fopts = ldFinderOpts opts + mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj (moduleName mod) + where + found loc mod = do { + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} + + adjust_linkable lnk + | Just new_osuf <- maybe_normal_osuf = do + new_uls <- mapM (adjust_ul new_osuf) + (linkableUnlinked lnk) + return lnk{ linkableUnlinked=new_uls } + | otherwise = + return lnk + + adjust_ul new_osuf (DotO file) = do + massert (osuf `isSuffixOf` file) + let file_base = fromJust (stripExtension osuf file) + new_file = file_base <.> new_osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith opts span $ + text "cannot find object file " + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) + adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) + adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) + adjust_ul _ l@(BCOs {}) = return l + adjust_ul _ l@LoadedBCOs{} = return l + adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod) + +{- +Note [Using Byte Code rather than Object Code for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The `-fprefer-byte-code` flag allows a user to specify that they want to use +byte code (if availble) rather than object code for home module dependenices +when executing Template Haskell splices. + +Why might you want to use byte code rather than object code? + +* Producing object code is much slower than producing byte code (for example if you're using -fno-code) +* Linking many large object files, which happens once per splice, is quite expensive. (#21700) + +So we allow the user to choose to use byte code rather than object files if they want to avoid these +two pitfalls. + +When using `-fprefer-byte-code` you have to arrange to have the byte code availble. +In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`. +See Note [Home module build products] for some more information about that. + +The only other place where the flag is consulted is when enabling code generation +with `-fno-code`, which does so to anticipate what decision we will make at the +splice point about what we would prefer. + +-} + +dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a +dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) + +throwProgramError :: LinkDepsOpts -> SDoc -> IO a +throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) + +checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay _opts interp _srcspan + | ExternalInterp {} <- interpInstance interp = return Nothing + -- with -fexternal-interpreter we load the .o files, whatever way + -- they were built. If they were built for a non-std way, then + -- we will use the appropriate variant of the iserv binary to load them. + +-- #if-guard the following equations otherwise the pattern match checker will +-- complain that they are redundant. +#if defined(HAVE_INTERNAL_INTERPRETER) +checkNonStdWay opts _interp srcspan + | hostFullWays == targetFullWays = return Nothing + -- Only if we are compiling with the same ways as GHC is built + -- with, can we dynamically load those object files. (see #3604) + + | ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays) + = failNonStd opts srcspan + + | otherwise = return (Just (hostWayTag ++ "o")) + where + targetFullWays = fullWays (ldWays opts) + hostWayTag = case waysTag hostFullWays of + "" -> "" + tag -> tag ++ "_" + + normalObjectSuffix :: String + normalObjectSuffix = "o" + +data Way' = Normal | Prof | Dyn + +failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath) +failNonStd opts srcspan = dieWith opts srcspan $ + text "Cannot load" <+> pprWay' compWay <+> + text "objects when GHC is built" <+> pprWay' ghciWay $$ + text "To fix this, either:" $$ + text " (1) Use -fexternal-interpreter, or" $$ + buildTwiceMsg + where compWay + | ldWays opts `hasWay` WayDyn = Dyn + | ldWays opts `hasWay` WayProf = Prof + | otherwise = Normal + ghciWay + | hostIsDynamic = Dyn + | hostIsProfiled = Prof + | otherwise = Normal + buildTwiceMsg = case (ghciWay, compWay) of + (Normal, Dyn) -> dynamicTooMsg + (Dyn, Normal) -> dynamicTooMsg + _ -> + text " (2) Build the program twice: once" <+> + pprWay' ghciWay <> text ", and then" $$ + text " " <> pprWay' compWay <+> + text "using -osuf to set a different object file suffix." + dynamicTooMsg = text " (2) Use -dynamic-too," <+> + text "and use -osuf and -dynosuf to set object file suffixes as needed." + pprWay' :: Way' -> SDoc + pprWay' way = text $ case way of + Normal -> "the normal way" + Prof -> "with -prof" + Dyn -> "with -dynamic" +#endif + diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -11,7 +11,6 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways -import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) import GHC.Driver.Config.Linker import GHC.Driver.Session @@ -151,9 +150,6 @@ -- dynamic binding nonsense when referring to symbols from -- within the library. The NCG assumes that this option is -- specified (on i386, at least). - -- In XCode 15, -single_module is the default and passing the - -- flag is now obsolete and raises a warning (#24168). We encode - -- this information into the toolchain field ...SupportsSingleModule. -- -install_name -- Mac OS/X stores the path where a dynamic library is (to -- be) installed in the library itself. It's called the @@ -179,11 +175,8 @@ ] ++ map Option o_files ++ [ Option "-undefined", - Option "dynamic_lookup" - ] - ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags) - then [ Option "-single_module" ] - else [ ]) + Option "dynamic_lookup", + Option "-single_module" ] ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] then [ ] else [ Option "-Wl,-read_only_relocs,suppress" ]) diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -29,6 +29,11 @@ , withExtendedLoadedEnv , extendLoadedEnv , deleteFromLoadedEnv + -- * Internals + , rmDupLinkables + , modifyLoaderState + , initLinkDepsOpts + , partitionLinkable ) where @@ -43,7 +48,6 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Finder @@ -51,7 +55,7 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes - +import GHC.Iface.Load import GHC.ByteCode.Linker import GHC.ByteCode.Asm @@ -68,24 +72,18 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Unit.Env -import GHC.Unit.Finder import GHC.Unit.Module -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.WholeCoreBindings -import GHC.Unit.Module.Deps -import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages import qualified GHC.Data.ShortText as ST -import qualified GHC.Data.Maybe as Maybes import GHC.Data.FastString +import GHC.Linker.Deps import GHC.Linker.MacOS import GHC.Linker.Dynamic import GHC.Linker.Types @@ -94,10 +92,9 @@ import Control.Monad import qualified Data.Set as Set -import qualified Data.Map as M import Data.Char (isSpace) import Data.IORef -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +import Data.List (intercalate, isPrefixOf, nub, partition) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC @@ -113,14 +110,6 @@ import GHC.Utils.Exception -import GHC.Unit.Module.Graph -import GHC.Types.SourceFile -import GHC.Utils.Misc -import GHC.Iface.Load -import GHC.Unit.Home -import Data.Either -import Control.Applicative - uninitialised :: a uninitialised = panic "Loader not initialised" @@ -207,28 +196,23 @@ -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required loadDependencies interp hsc_env pls span needed_mods = do -- initLoaderState (hsc_dflags hsc_env) dl - let dflags = hsc_dflags hsc_env - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags interp span + let opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required - (lnks, all_lnks, pkgs, this_pkgs_needed) - <- getLinkDeps hsc_env pls - maybe_normal_osuf span needed_mods + deps <- getLinkDeps opts interp pls span needed_mods + let this_pkgs_needed = ldNeededUnits deps + -- Link the packages and modules required - pls1 <- loadPackages' interp hsc_env pkgs pls - (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks + pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls + (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps) let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed all_pkgs_loaded = pkgs_loaded pls2 trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg | pkg_id <- uniqDSetToList this_pkgs_needed , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id] ]) - return (pls2, succ, all_lnks, this_pkgs_loaded) + return (pls2, succ, ldAllLinkables deps, this_pkgs_loaded) -- | Temporarily extend the loaded env. @@ -303,17 +287,24 @@ -- Initialise the linker state let pls0 = emptyLoaderState - -- (a) initialise the C dynamic linker - initObjLinker interp + case platformArch (targetPlatform (hsc_dflags hsc_env)) of + -- FIXME: we don't initialize anything with the JS interpreter. + -- Perhaps we should load preload packages. We'll load them on demand + -- anyway. + ArchJavaScript -> return pls0 + _ -> do + -- (a) initialise the C dynamic linker + initObjLinker interp - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) - -- steps (c), (d) and (e) - loadCmdLineLibs' interp hsc_env pls + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) + -- steps (c), (d) and (e) + loadCmdLineLibs' interp hsc_env pls + loadCmdLineLibs :: Interp -> HscEnv -> IO () loadCmdLineLibs interp hsc_env = do initLoaderState interp hsc_env @@ -598,8 +589,7 @@ nobreakarray = error "no break array" bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco - bco_opts <- initBCOOpts (hsc_dflags hsc_env) - [root_hvref] <- createBCOs interp bco_opts [resolved] + [root_hvref] <- createBCOs interp [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv) where @@ -615,313 +605,28 @@ -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a -dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg))) - - -checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath) -checkNonStdWay _dflags interp _srcspan - | ExternalInterp {} <- interpInstance interp = return Nothing - -- with -fexternal-interpreter we load the .o files, whatever way - -- they were built. If they were built for a non-std way, then - -- we will use the appropriate variant of the iserv binary to load them. - --- #if-guard the following equations otherwise the pattern match checker will --- complain that they are redundant. -#if defined(HAVE_INTERNAL_INTERPRETER) -checkNonStdWay dflags _interp srcspan - | hostFullWays == targetFullWays = return Nothing - -- Only if we are compiling with the same ways as GHC is built - -- with, can we dynamically load those object files. (see #3604) - - | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays) - = failNonStd dflags srcspan - - | otherwise = return (Just (hostWayTag ++ "o")) - where - targetFullWays = fullWays (ways dflags) - hostWayTag = case waysTag hostFullWays of - "" -> "" - tag -> tag ++ "_" - - normalObjectSuffix :: String - normalObjectSuffix = phaseInputExt StopLn - -data Way' = Normal | Prof | Dyn - -failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -failNonStd dflags srcspan = dieWith dflags srcspan $ - text "Cannot load" <+> pprWay' compWay <+> - text "objects when GHC is built" <+> pprWay' ghciWay $$ - text "To fix this, either:" $$ - text " (1) Use -fexternal-interpreter, or" $$ - buildTwiceMsg - where compWay - | ways dflags `hasWay` WayDyn = Dyn - | ways dflags `hasWay` WayProf = Prof - | otherwise = Normal - ghciWay - | hostIsDynamic = Dyn - | hostIsProfiled = Prof - | otherwise = Normal - buildTwiceMsg = case (ghciWay, compWay) of - (Normal, Dyn) -> dynamicTooMsg - (Dyn, Normal) -> dynamicTooMsg - _ -> - text " (2) Build the program twice: once" <+> - pprWay' ghciWay <> text ", and then" $$ - text " " <> pprWay' compWay <+> - text "using -osuf to set a different object file suffix." - dynamicTooMsg = text " (2) Use -dynamic-too," <+> - text "and use -osuf and -dynosuf to set object file suffixes as needed." - pprWay' :: Way' -> SDoc - pprWay' way = text $ case way of - Normal -> "the normal way" - Prof -> "with -prof" - Dyn -> "with -dynamic" -#endif - -getLinkDeps :: HscEnv - -> LoaderState - -> Maybe FilePath -- replace object suffixes? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first - -- The module and package dependencies for the needed modules are returned. - -- See Note [Object File Dependencies] --- Fails with an IO exception if it can't find enough files - -getLinkDeps hsc_env pls replace_osuf span mods --- Find all the packages and linkables that a set of modules depends on - = do { - -- 1. Find the dependent home-pkg-modules/packages from each iface - -- (omitting modules from the interactive package, which is already linked) - ; (mods_s, pkgs_s) <- - -- Why two code paths here? There is a significant amount of repeated work - -- performed calculating transitive dependencies - -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests) - if isOneShot (ghcMode dflags) - then follow_deps (filterOut isInteractiveModule mods) - emptyUniqDSet emptyUniqDSet; - else do - (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods - return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs)) - - ; let - -- 2. Exclude ones already linked - -- Main reason: avoid findModule calls in get_linkable - (mods_needed, links_got) = partitionEithers (map split_mods mods_s) - pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls - - split_mods mod = - let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (bcos_loaded pls) mod - in case is_linked of - Just linkable -> Right linkable - Nothing -> Left mod - - -- 3. For each dependent module, find its linkable - -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable - ; let { osuf = objectSuf dflags } - ; lnks_needed <- mapM (get_linkable osuf) mods_needed - - ; return (lnks_needed, links_got ++ lnks_needed, pkgs_needed, pkgs_s) } +initLinkDepsOpts :: HscEnv -> LinkDepsOpts +initLinkDepsOpts hsc_env = opts where + opts = LinkDepsOpts + { ldObjSuffix = objectSuf dflags + , ldOneShotMode = isOneShot (ghcMode dflags) + , ldModuleGraph = hsc_mod_graph hsc_env + , ldUnitEnv = hsc_unit_env hsc_env + , ldLoadIface = load_iface + , ldPprOpts = initSDocContext dflags defaultUserStyle + , ldFinderCache = hsc_FC hsc_env + , ldFinderOpts = initFinderOpts dflags + , ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags + , ldMsgOpts = initIfaceMessageOpts dflags + , ldWays = ways dflags + } dflags = hsc_dflags hsc_env - mod_graph = hsc_mod_graph hsc_env - - -- This code is used in `--make` mode to calculate the home package and unit dependencies - -- for a set of modules. - -- - -- It is significantly more efficient to use the shared transitive dependency - -- calculation than to compute the transitive dependency set in the same manner as oneShot mode. - - -- It is also a matter of correctness to use the module graph so that dependencies between home units - -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) - make_deps_loop found [] = found - make_deps_loop found@(found_units, found_mods) (nk:nexts) - | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts - | otherwise = - case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of - Just trans_deps -> - let deps = Set.insert (NodeKey_Module nk) trans_deps - -- See #936 and the ghci.prog007 test for why we have to continue traversing through - -- boot modules. - todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps] - in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts) - Nothing -> - let (ModNodeKeyWithUid _ uid) = nk - in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts - - mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) - (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) - - all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] - - get_mod_info (ModNodeKeyWithUid gwib uid) = - case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of - Just hmi -> - let iface = (hm_iface hmi) - mmod = case mi_hsc_src iface of - HsBootFile -> link_boot_mod_error (mi_module iface) - _ -> return $ Just (mi_module iface) - - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod - Nothing -> - let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid - in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - - - -- This code is used in one-shot mode to traverse downwards through the HPT - -- to find all link dependencies. - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. - follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result - follow_deps [] acc_mods acc_pkgs - = return (uniqDSetToList acc_mods, acc_pkgs) - follow_deps (mod:mods) acc_mods acc_pkgs - = do - mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ - loadInterface msg mod (ImportByUser NotBoot) - iface <- case mb_iface of - Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Maybes.Succeeded iface -> return iface - - when (mi_boot iface == IsBoot) $ link_boot_mod_error mod - - let - pkg = moduleUnit mod - deps = mi_deps iface - - pkg_deps = dep_direct_pkgs deps - (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $ - \case - (_, GWIB m IsBoot) -> Left m - (_, GWIB m NotBoot) -> Right m - - mod_deps' = case hsc_home_unit_maybe hsc_env of - Nothing -> [] - Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps)) - acc_mods' = case hsc_home_unit_maybe hsc_env of - Nothing -> acc_mods - Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) - - case hsc_home_unit_maybe hsc_env of - Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) - acc_mods' acc_pkgs' - _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) - where - msg = text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" + load_iface msg mod = initIfaceCheck (text "loader") hsc_env + $ loadInterface msg mod (ImportByUser NotBoot) - link_boot_mod_error :: Module -> IO a - link_boot_mod_error mod = - throwGhcExceptionIO (ProgramError (showSDoc dflags ( - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module"))) - - no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith dflags span $ - text "cannot find object file for module " <> - quotes (ppr mod) $$ - while_linking_expr - - while_linking_expr = text "while linking an interpreted expression" - - - -- See Note [Using Byte Code rather than Object Code for Template Haskell] - homeModLinkable :: DynFlags -> HomeModInfo -> Maybe Linkable - homeModLinkable dflags hmi = - if gopt Opt_UseBytecodeRatherThanObjects dflags - then homeModInfoByteCode hmi <|> homeModInfoObject hmi - else homeModInfoObject hmi <|> homeModInfoByteCode hmi - - get_linkable osuf mod -- A home-package module - | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env) - = adjust_linkable (Maybes.expectJust "getLinkDeps" (homeModLinkable dflags mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - case hsc_home_unit_maybe hsc_env of - Nothing -> no_obj mod - Just home_unit -> do - - let fc = hsc_FC hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj (moduleName mod) - where - found loc mod = do { - -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod loc ; - case mb_lnk of { - Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk - }} - - adjust_linkable lnk - | Just new_osuf <- replace_osuf = do - new_uls <- mapM (adjust_ul new_osuf) - (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } - | otherwise = - return lnk - - adjust_ul new_osuf (DotO file) = do - massert (osuf `isSuffixOf` file) - let file_base = fromJust (stripExtension osuf file) - new_file = file_base <.> new_osuf - ok <- doesFileExist new_file - if (not ok) - then dieWith dflags span $ - text "cannot find object file " - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file) - adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) - adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) - adjust_ul _ l@(BCOs {}) = return l - adjust_ul _ l@LoadedBCOs{} = return l - adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod) - -{- -Note [Using Byte Code rather than Object Code for Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The `-fprefer-byte-code` flag allows a user to specify that they want to use -byte code (if availble) rather than object code for home module dependenices -when executing Template Haskell splices. - -Why might you want to use byte code rather than object code? - -* Producing object code is much slower than producing byte code (for example if you're using -fno-code) -* Linking many large object files, which happens once per splice, is quite expensive. (#21700) - -So we allow the user to choose to use byte code rather than object files if they want to avoid these -two pitfalls. - -When using `-fprefer-byte-code` you have to arrange to have the byte code availble. -In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`. -See Note [Home module build products] for some more information about that. - -The only other place where the flag is consulted is when enabling code generation -with `-fno-code`, which does so to anticipate what decision we will make at the -splice point about what we would prefer. - --} - {- ********************************************************************** Loading a Decls statement @@ -946,11 +651,10 @@ , addr_env = plusNameEnv (addr_env le) bc_strs } -- Link the necessary packages and linkables - bco_opts <- initBCOOpts (hsc_dflags hsc_env) - new_bindings <- linkSomeBCOs bco_opts interp le2 [cbc] + new_bindings <- linkSomeBCOs interp le2 [cbc] nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let ce2 = extendClosureEnv (closure_env le2) nms_fhvs - pls2 = pls { linker_env = le2 { closure_env = ce2 } } + !pls2 = pls { linker_env = le2 { closure_env = ce2 } } return (pls2, (nms_fhvs, links_needed, units_needed)) where free_names = uniqDSetToList $ @@ -995,7 +699,6 @@ let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables) - bco_opts <- initBCOOpts (hsc_dflags hsc_env) -- Load objects first; they can't depend on BCOs (pls1, ok_flag) <- loadObjects interp hsc_env pls objs @@ -1003,7 +706,7 @@ if failed ok_flag then return (pls1, Failed) else do - pls2 <- dynLinkBCOs bco_opts interp pls1 bcos + pls2 <- dynLinkBCOs interp pls1 bcos return (pls2, Succeeded) @@ -1019,12 +722,9 @@ li {linkableUnlinked=li_uls_bco}] _ -> [li] -findModuleLinkable_maybe :: LinkableSet -> Module -> Maybe Linkable -findModuleLinkable_maybe = lookupModuleEnv - linkableInSet :: Linkable -> LinkableSet -> Bool linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModule l) of + case lookupModuleEnv objs_loaded (linkableModule l) of Nothing -> False Just m -> linkableTime l == linkableTime m @@ -1156,8 +856,8 @@ ********************************************************************* -} -dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState -dynLinkBCOs bco_opts interp pls bcos = do +dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState +dynLinkBCOs interp pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } @@ -1173,7 +873,7 @@ ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) le2 = le1 { itbl_env = ie2, addr_env = ae2 } - names_and_refs <- linkSomeBCOs bco_opts interp le2 cbcs + names_and_refs <- linkSomeBCOs interp le2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -1184,11 +884,10 @@ new_binds <- makeForeignNamedHValueRefs interp to_add let ce2 = extendClosureEnv (closure_env le2) new_binds - return pls1 { linker_env = le2 { closure_env = ce2 } } + return $! pls1 { linker_env = le2 { closure_env = ce2 } } -- Link a bunch of BCOs and return references to their values -linkSomeBCOs :: BCOOpts - -> Interp +linkSomeBCOs :: Interp -> LinkerEnv -> [CompiledByteCode] -> IO [(Name,HValueRef)] @@ -1196,7 +895,7 @@ -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs bco_opts interp le mods = foldr fun do_link mods [] +linkSomeBCOs interp le mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = case bc_breaks of @@ -1211,7 +910,7 @@ bco_ix = mkNameEnv (zip names [0..]) resolved <- sequence [ linkBCO interp le bco_ix breakarray bco | (breakarray, bco) <- flat ] - hvrefs <- createBCOs interp bco_opts resolved + hvrefs <- createBCOs interp resolved return (zip names hvrefs) -- | Useful to apply to the result of 'linkSomeBCOs' diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -11,7 +11,7 @@ import GHC.Linker.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Unit.Types import GHC.Unit.State diff --git a/compiler/GHC/Llvm/MetaData.hs b/compiler/GHC/Llvm/MetaData.hs --- a/compiler/GHC/Llvm/MetaData.hs +++ b/compiler/GHC/Llvm/MetaData.hs @@ -64,7 +64,12 @@ deriving (Eq, Ord, Enum) instance Outputable MetaId where - ppr (MetaId n) = char '!' <> int n + ppr = ppMetaId + +ppMetaId :: IsLine doc => MetaId -> doc +ppMetaId (MetaId n) = char '!' <> int n +{-# SPECIALIZE ppMetaId :: MetaId -> SDoc #-} +{-# SPECIALIZE ppMetaId :: MetaId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | LLVM metadata expressions data MetaExpr = MetaStr !LMString 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 @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} -------------------------------------------------------------------------------- -- | Pretty print LLVM IR Code. @@ -36,10 +37,10 @@ import GHC.Llvm.MetaData import GHC.Llvm.Types -import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable +import GHC.Cmm.MachOp ( FMASign(..), pprFMASign ) import GHC.CmmToLlvm.Config import GHC.Utils.Panic import GHC.Types.Unique @@ -49,30 +50,39 @@ -------------------------------------------------------------------------------- -- | Print out a whole LLVM module. -ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc +ppLlvmModule :: IsDoc doc => LlvmCgConfig -> LlvmModule -> doc ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs) - = ppLlvmComments comments $+$ newLine - $+$ ppLlvmAliases aliases $+$ newLine - $+$ ppLlvmMetas opts meta $+$ newLine - $+$ ppLlvmGlobals opts globals $+$ newLine - $+$ ppLlvmFunctionDecls decls $+$ newLine - $+$ ppLlvmFunctions opts funcs + = ppLlvmComments comments $$ newLine + $$ ppLlvmAliases aliases $$ newLine + $$ ppLlvmMetas opts meta $$ newLine + $$ ppLlvmGlobals opts globals $$ newLine + $$ ppLlvmFunctionDecls decls $$ newLine + $$ ppLlvmFunctions opts funcs +{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc #-} +{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Print out a multi-line comment, can be inside a function or on its own -ppLlvmComments :: [LMString] -> SDoc -ppLlvmComments comments = vcat $ map ppLlvmComment comments +ppLlvmComments :: IsDoc doc => [LMString] -> doc +ppLlvmComments comments = lines_ $ map ppLlvmComment comments +{-# SPECIALIZE ppLlvmComments :: [LMString] -> SDoc #-} +{-# SPECIALIZE ppLlvmComments :: [LMString] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a comment, can be inside a function or on its own -ppLlvmComment :: LMString -> SDoc +ppLlvmComment :: IsLine doc => LMString -> doc ppLlvmComment com = semi <+> ftext com +{-# SPECIALIZE ppLlvmComment :: LMString -> SDoc #-} +{-# SPECIALIZE ppLlvmComment :: LMString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of global mutable variable definitions -ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc -ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls +ppLlvmGlobals :: IsDoc doc => LlvmCgConfig -> [LMGlobal] -> doc +ppLlvmGlobals opts ls = lines_ $ map (ppLlvmGlobal opts) ls +{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc #-} +{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a global mutable variable definition -ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc +ppLlvmGlobal :: IsLine doc => LlvmCgConfig -> LMGlobal -> doc ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = let sect = case x of Just x' -> text ", section" <+> doubleQuotes (ftext x') @@ -84,7 +94,7 @@ rhs = case dat of Just stat -> pprSpecialStatic opts stat - Nothing -> ppr (pLower $ getVarType var) + Nothing -> ppLlvmType (pLower $ getVarType var) -- Position of linkage is different for aliases. const = case c of @@ -92,105 +102,130 @@ Constant -> "constant" Alias -> "alias" - in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align - $+$ newLine + in ppAssignment opts var $ ppLlvmLinkageType link <+> text const <+> rhs <> sect <> align ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $ - text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val) + text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic @SDoc opts) val) +{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc #-} +{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of LLVM type aliases. -ppLlvmAliases :: [LlvmAlias] -> SDoc -ppLlvmAliases tys = vcat $ map ppLlvmAlias tys +ppLlvmAliases :: IsDoc doc => [LlvmAlias] -> doc +ppLlvmAliases tys = lines_ $ map ppLlvmAlias tys +{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> SDoc #-} +{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM type alias. -ppLlvmAlias :: LlvmAlias -> SDoc +ppLlvmAlias :: IsLine doc => LlvmAlias -> doc ppLlvmAlias (name, ty) - = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty + = char '%' <> ftext name <+> equals <+> text "type" <+> ppLlvmType ty +{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> SDoc #-} +{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of LLVM metadata. -ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc -ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas +ppLlvmMetas :: IsDoc doc => LlvmCgConfig -> [MetaDecl] -> doc +ppLlvmMetas opts metas = lines_ $ map (ppLlvmMeta opts) metas +{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc #-} +{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM metadata definition. -ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc +ppLlvmMeta :: IsLine doc => LlvmCgConfig -> MetaDecl -> doc ppLlvmMeta opts (MetaUnnamed n m) - = ppr n <+> equals <+> ppMetaExpr opts m + = ppMetaId n <+> equals <+> ppMetaExpr opts m ppLlvmMeta _opts (MetaNamed n m) = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes where - nodes = hcat $ intersperse comma $ map ppr m + nodes = hcat $ intersperse comma $ map ppMetaId m +{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc #-} +{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of function definitions. -ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc +ppLlvmFunctions :: IsDoc doc => LlvmCgConfig -> LlvmFunctions -> doc ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs +{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a function definition. -ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc +ppLlvmFunction :: IsDoc doc => LlvmCgConfig -> LlvmFunction -> doc ppLlvmFunction opts fun = - let attrDoc = ppSpaceJoin (funcAttrs fun) + let attrDoc = ppSpaceJoin ppLlvmFuncAttr (funcAttrs fun) secDoc = case funcSect fun of Just s' -> text "section" <+> (doubleQuotes $ ftext s') Nothing -> empty prefixDoc = case funcPrefix fun of Just v -> text "prefix" <+> ppStatic opts v Nothing -> empty - in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) - <+> attrDoc <+> secDoc <+> prefixDoc - $+$ lbrace - $+$ ppLlvmBlocks opts (funcBody fun) - $+$ rbrace - $+$ newLine - $+$ newLine + in vcat + [line $ text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) + <+> attrDoc <+> secDoc <+> prefixDoc + , line lbrace + , ppLlvmBlocks opts (funcBody fun) + , line rbrace + , newLine + , newLine] +{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc #-} +{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a function definition header. -ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc +ppLlvmFunctionHeader :: IsLine doc => LlvmFunctionDecl -> [LMString] -> doc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args = let varg' = case varg of VarArgs | null p -> text "..." | otherwise -> text ", ..." _otherwise -> text "" align = case a of - Just a' -> text " align " <> ppr a' + Just a' -> text " align " <> int a' Nothing -> empty - args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' + args' = zipWith (\(ty,p) n -> ppLlvmType ty <+> ppSpaceJoin ppLlvmParamAttr p <+> char '%' <> ftext n) - (zip p args) - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> - (hsep $ punctuate comma args') <> varg' <> rparen <> align + p + args + in ppLlvmLinkageType l <+> ppLlvmCallConvention c <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> + hsep (punctuate comma args') <> varg' <> rparen <> align +{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of function declaration. -ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc +ppLlvmFunctionDecls :: IsDoc doc => LlvmFunctionDecls -> doc ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs +{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a function declaration. -- Declarations define the function type but don't define the actual body of -- the function. -ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc +ppLlvmFunctionDecl :: IsDoc doc => LlvmFunctionDecl -> doc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) = let varg' = case varg of VarArgs | null p -> text "..." | otherwise -> text ", ..." _otherwise -> text "" align = case a of - Just a' -> text " align" <+> ppr a' + Just a' -> text " align" <+> int a' Nothing -> empty args = hcat $ intersperse (comma <> space) $ - map (\(t,a) -> ppr t <+> ppSpaceJoin a) p - in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> - ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine + map (\(t,a) -> ppLlvmType t <+> ppSpaceJoin ppLlvmParamAttr a) p + in lines_ + [ text "declare" <+> ppLlvmLinkageType l <+> ppLlvmCallConvention c + <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> args <> varg' <> rparen <> align + , empty] +{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of LLVM blocks. -ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc +ppLlvmBlocks :: IsDoc doc => LlvmCgConfig -> LlvmBlocks -> doc ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks +{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc #-} +{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM block. -- It must be part of a function definition. -ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc +ppLlvmBlock :: IsDoc doc => LlvmCgConfig -> LlvmBlock -> doc ppLlvmBlock opts (LlvmBlock blockId stmts) = let isLabel (MkLabel _) = True isLabel _ = False @@ -198,39 +233,44 @@ ppRest = case rest of MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs) _ -> empty - in ppLlvmBlockLabel blockId - $+$ (vcat $ map (ppLlvmStatement opts) block) - $+$ newLine - $+$ ppRest + in vcat $ + line (ppLlvmBlockLabel blockId) + : map (ppLlvmStatement opts) block + ++ [ empty , ppRest ] +{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc #-} +{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> SDoc +ppLlvmBlockLabel :: IsLine doc => LlvmBlockId -> doc ppLlvmBlockLabel id = pprUniqueAlways id <> colon +{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> SDoc #-} +{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable --- | Print out an LLVM statement. -ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc +-- | Print out an LLVM statement, with any metadata to append to the statement. +ppLlvmStatement :: IsDoc doc => LlvmCgConfig -> LlvmStatement -> doc ppLlvmStatement opts stmt = - let ind = (text " " <>) + let ind = line . (text " " <>) in case stmt of Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr) Fence st ord -> ind $ ppFence st ord Branch target -> ind $ ppBranch opts target BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF - Comment comments -> ind $ ppLlvmComments comments - MkLabel label -> ppLlvmBlockLabel label - Store value ptr align - -> ind $ ppStore opts value ptr align - Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs + Comment comments -> ppLlvmComments comments + MkLabel label -> line $ ppLlvmBlockLabel label + Store value ptr align metas + -> ind $ ppStore opts value ptr align metas + Switch scrut def tgs -> ppSwitch opts scrut def tgs Return result -> ind $ ppReturn opts result Expr expr -> ind $ ppLlvmExpression opts expr Unreachable -> ind $ text "unreachable" - Nop -> empty - MetaStmt meta s -> ppMetaStatement opts meta s + Nop -> line empty +{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc #-} +{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM expression. -ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc +ppLlvmExpression :: IsLine doc => LlvmCgConfig -> LlvmExpression -> doc ppLlvmExpression opts expr = case expr of Alloca tp amount -> ppAlloca opts tp amount @@ -249,16 +289,21 @@ AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord Phi tp predecessors -> ppPhi opts tp predecessors + FMAOp op x y z -> pprFMAOp opts op x y z Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk MExpr meta expr -> ppMetaAnnotExpr opts meta expr +{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-} +{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc +ppMetaExpr :: IsLine doc => LlvmCgConfig -> MetaExpr -> doc ppMetaExpr opts = \case MetaVar (LMLitVar (LMNullLit _)) -> text "null" MetaStr s -> char '!' <> doubleQuotes (ftext s) - MetaNode n -> ppr n + MetaNode n -> ppMetaId n MetaVar v -> ppVar opts v - MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es)) + MetaStruct es -> char '!' <> braces (ppCommaJoin (ppMetaExpr opts) es) +{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc #-} +{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -------------------------------------------------------------------------------- @@ -267,7 +312,8 @@ -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type. -ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc +ppCall :: forall doc. IsLine doc => LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] + -> [LlvmFuncAttr] -> doc ppCall opts ct fptr args attrs = case fptr of -- -- if local var function pointer, unwrap @@ -285,32 +331,36 @@ ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCallParams opts (map snd params) args - ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <> + ppArgTy = ppCommaJoin (ppLlvmType . fst) params <> (case argTy of VarArgs -> text ", ..." FixedArgs -> empty) fnty = space <> lparen <> ppArgTy <> rparen - attrDoc = ppSpaceJoin attrs - in tc <> text "call" <+> ppr cc <+> ppr ret + attrDoc = ppSpaceJoin ppLlvmFuncAttr attrs + in tc <> text "call" <+> ppLlvmCallConvention cc <+> ppLlvmType ret <> fnty <+> ppName opts fptr <> lparen <+> ppValues <+> rparen <+> attrDoc - ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc + ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> doc ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args where -- Metadata needs to be marked as having the `metadata` type when used -- in a call argument ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v +{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc #-} +{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc +ppMachOp :: IsLine doc => LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> doc ppMachOp opts op left right = - (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left + ppLlvmMachOp op <+> ppLlvmType (getVarType left) <+> ppName opts left <> comma <+> ppName opts right +{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc +ppCmpOp :: IsLine doc => LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> doc ppCmpOp opts op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp" @@ -321,28 +371,42 @@ ++ (show $ getVarType left) ++ ", right = " ++ (show $ getVarType right)) -} - in cmpOp <+> ppr op <+> ppr (getVarType left) + in cmpOp <+> ppLlvmCmpOp op <+> ppLlvmType (getVarType left) <+> ppName opts left <> comma <+> ppName opts right +{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +pprFMAOp :: IsLine doc => LlvmCgConfig -> FMASign -> LlvmVar -> LlvmVar -> LlvmVar -> doc +pprFMAOp opts signs x y z = + pprFMASign signs <+> ppLlvmType (getVarType x) + <+> ppName opts x <> comma + <+> ppName opts y <> comma + <+> ppName opts z -ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc +ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc ppAssignment opts var expr = ppName opts var <+> equals <+> expr +{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc #-} +{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> HLine -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppFence :: Bool -> LlvmSyncOrdering -> SDoc +ppFence :: IsLine doc => Bool -> LlvmSyncOrdering -> doc ppFence st ord = let singleThread = case st of True -> text "singlethread" False -> empty in text "fence" <+> singleThread <+> ppSyncOrdering ord +{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppSyncOrdering :: LlvmSyncOrdering -> SDoc +ppSyncOrdering :: IsLine doc => LlvmSyncOrdering -> doc ppSyncOrdering SyncUnord = text "unordered" ppSyncOrdering SyncMonotonic = text "monotonic" ppSyncOrdering SyncAcquire = text "acquire" ppSyncOrdering SyncRelease = text "release" ppSyncOrdering SyncAcqRel = text "acq_rel" ppSyncOrdering SyncSeqCst = text "seq_cst" +{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAtomicOp :: LlvmAtomicOp -> SDoc +ppAtomicOp :: IsLine doc => LlvmAtomicOp -> doc ppAtomicOp LAO_Xchg = text "xchg" ppAtomicOp LAO_Add = text "add" ppAtomicOp LAO_Sub = text "sub" @@ -354,184 +418,222 @@ ppAtomicOp LAO_Min = text "min" ppAtomicOp LAO_Umax = text "umax" ppAtomicOp LAO_Umin = text "umin" +{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> SDoc #-} +{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc +ppAtomicRMW :: IsLine doc => LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> doc ppAtomicRMW opts aop tgt src ordering = text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma <+> ppVar opts src <+> ppSyncOrdering ordering +{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar - -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc +ppCmpXChg :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar + -> LlvmSyncOrdering -> LlvmSyncOrdering -> doc ppCmpXChg opts addr old new s_ord f_ord = text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord +{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc +ppLoad :: IsLine doc => LlvmCgConfig -> LlvmVar -> LMAlign -> doc ppLoad opts var alignment = - text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align + text "load" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> align where derefType = pLower $ getVarType var align = case alignment of - Just n -> text ", align" <+> ppr n + Just n -> text ", align" <+> int n Nothing -> empty +{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc #-} +{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc +ppALoad :: IsLine doc => LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> doc ppALoad opts ord st var = let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8 - align = text ", align" <+> ppr alignment + align = text ", align" <+> int alignment sThreaded | st = text " singlethread" | otherwise = empty derefType = pLower $ getVarType var - in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded + in text "load atomic" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> sThreaded <+> ppSyncOrdering ord <> align +{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc -ppStore opts val dst alignment = - text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align +ppStore :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> doc +ppStore opts val dst alignment metas = + text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align <+> ppMetaAnnots opts metas where align = case alignment of - Just n -> text ", align" <+> ppr n + Just n -> text ", align" <+> int n Nothing -> empty +{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> SDoc #-} +{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc +ppCast :: IsLine doc => LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> doc ppCast opts op from to - = ppr op - <+> ppr (getVarType from) <+> ppName opts from + = ppLlvmCastOp op + <+> ppLlvmType (getVarType from) <+> ppName opts from <+> text "to" - <+> ppr to + <+> ppLlvmType to +{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc #-} +{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc +ppMalloc :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc ppMalloc opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount' - + in text "malloc" <+> ppLlvmType tp <> comma <+> ppVar opts amount' +{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-} +{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc +ppAlloca :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc ppAlloca opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount' - + in text "alloca" <+> ppLlvmType tp <> comma <+> ppVar opts amount' +{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-} +{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc +ppGetElementPtr :: IsLine doc => LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> doc ppGetElementPtr opts inb ptr idx = - let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx) + let indexes = comma <+> ppCommaJoin (ppVar opts) idx inbound = if inb then text "inbounds" else empty derefType = pLower $ getVarType ptr - in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr + in text "getelementptr" <+> inbound <+> ppLlvmType derefType <> comma <+> ppVar opts ptr <> indexes +{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc #-} +{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc +ppReturn :: IsLine doc => LlvmCgConfig -> Maybe LlvmVar -> doc ppReturn opts (Just var) = text "ret" <+> ppVar opts var -ppReturn _ Nothing = text "ret" <+> ppr LMVoid - +ppReturn _ Nothing = text "ret" <+> ppLlvmType LMVoid +{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc #-} +{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc +ppBranch :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppBranch opts var = text "br" <+> ppVar opts var +{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppBranchIf :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc ppBranchIf opts cond trueT falseT = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT +{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc +ppPhi :: IsLine doc => LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> doc ppPhi opts tp preds = let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label - in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) + in text "phi" <+> ppLlvmType tp <+> hsep (punctuate comma $ map ppPreds preds) +{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc #-} +{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc +ppSwitch :: IsDoc doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> doc ppSwitch opts scrut dflt targets = - let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab - ppTargets xs = brackets $ vcat (map ppTarget xs) - in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt - <+> ppTargets targets + let ppTarget (val, lab) = text " " <> ppVar opts val <> comma <+> ppVar opts lab + in lines_ $ concat + [ [text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt <+> char '['] + , map ppTarget targets + , [char ']'] + ] +{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc #-} +{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc +ppAsm :: IsLine doc => LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> doc ppAsm opts asm constraints rty vars sideeffect alignstack = let asm' = doubleQuotes $ ftext asm cons = doubleQuotes $ ftext constraints - rty' = ppr rty - vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen + rty' = ppLlvmType rty + vars' = lparen <+> ppCommaJoin (ppVar opts) vars <+> rparen side = if sideeffect then text "sideeffect" else empty align = if alignstack then text "alignstack" else empty in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma <+> cons <> vars' +{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc #-} +{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc +ppExtract :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> doc ppExtract opts vec idx = text "extractelement" - <+> ppr (getVarType vec) <+> ppName opts vec <> comma + <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma <+> ppVar opts idx +{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc +ppExtractV :: IsLine doc => LlvmCgConfig -> LlvmVar -> Int -> doc ppExtractV opts struct idx = text "extractvalue" - <+> ppr (getVarType struct) <+> ppName opts struct <> comma - <+> ppr idx + <+> ppLlvmType (getVarType struct) <+> ppName opts struct <> comma + <+> int idx +{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc #-} +{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppInsert :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc ppInsert opts vec elt idx = text "insertelement" - <+> ppr (getVarType vec) <+> ppName opts vec <> comma - <+> ppr (getVarType elt) <+> ppName opts elt <> comma + <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma + <+> ppLlvmType (getVarType elt) <+> ppName opts elt <> comma <+> ppVar opts idx - - -ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc -ppMetaStatement opts meta stmt = - ppLlvmStatement opts stmt <> ppMetaAnnots opts meta +{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc +ppMetaAnnotExpr :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> doc ppMetaAnnotExpr opts meta expr = ppLlvmExpression opts expr <> ppMetaAnnots opts meta +{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc #-} +{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc +ppMetaAnnots :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> doc ppMetaAnnots opts meta = hcat $ map ppMeta meta where ppMeta (MetaAnnot name e) = comma <+> exclamation <> ftext name <+> case e of - MetaNode n -> ppr n - MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms)) + MetaNode n -> ppMetaId n + MetaStruct ms -> exclamation <> braces (ppCommaJoin (ppMetaExpr opts) ms) other -> exclamation <> braces (ppMetaExpr opts other) -- possible? +{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc #-} +{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). -ppName :: LlvmCgConfig -> LlvmVar -> SDoc +ppName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppName opts v = case v of LMGlobalVar {} -> char '@' <> ppPlainName opts v LMLocalVar {} -> char '%' <> ppPlainName opts v LMNLocalVar {} -> char '%' <> ppPlainName opts v LMLitVar {} -> ppPlainName opts v +{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@). -ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc +ppPlainName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppPlainName opts v = case v of (LMGlobalVar x _ _ _ _ _) -> ftext x (LMLocalVar x LMLabel ) -> pprUniqueAlways x (LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x (LMNLocalVar x _ ) -> ftext x (LMLitVar x ) -> ppLit opts x +{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print a literal value. No type. -ppLit :: LlvmCgConfig -> LlvmLit -> SDoc +ppLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc ppLit opts l = case l of - (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32) - (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64) - (LMIntLit i _ ) -> ppr ((fromInteger i)::Int) + (LMIntLit i _ ) -> integer i (LMFloatLit r LMFloat ) -> ppFloat (llvmCgPlatform opts) $ narrowFp r (LMFloatLit r LMDouble) -> ppDouble (llvmCgPlatform opts) r f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f) - (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>' + (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (ppTypeLit opts) ls <+> char '>' (LMNullLit _ ) -> text "null" -- #11487 was an issue where we passed undef for some arguments -- that were actually live. By chance the registers holding those @@ -544,61 +646,76 @@ | llvmCgFillUndefWithGarbage opts , Just lit <- garbageLit t -> ppLit opts lit | otherwise -> text "undef" +{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppVar :: LlvmCgConfig -> LlvmVar -> SDoc +ppVar :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppVar = ppVar' [] +{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc +ppVar' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> doc ppVar' attrs opts v = case v of LMLitVar x -> ppTypeLit' attrs opts x - x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x + x -> ppLlvmType (getVarType x) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppName opts x +{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc +ppTypeLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc ppTypeLit = ppTypeLit' [] +{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc +ppTypeLit' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> doc ppTypeLit' attrs opts l = case l of LMVectorLit {} -> ppLit opts l - _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l + _ -> ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l +{-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc +ppStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc ppStatic opts st = case st of LMComment s -> text "; " <> ftext s LMStaticLit l -> ppTypeLit opts l - LMUninitType t -> ppr t <> text " undef" - LMStaticStr s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\"" - LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']' - LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>" - LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}" + LMUninitType t -> ppLlvmType t <> text " undef" + LMStaticStr s t -> ppLlvmType t <> text " c\"" <> ftext s <> text "\\00\"" + LMStaticArray d t -> ppLlvmType t <> text " [" <> ppCommaJoin (ppStatic opts) d <> char ']' + LMStaticStruc d t -> ppLlvmType t <> text "<{" <> ppCommaJoin (ppStatic opts) d <> text "}>" + LMStaticStrucU d t -> ppLlvmType t <> text "{" <> ppCommaJoin (ppStatic opts) d <> text "}" LMStaticPointer v -> ppVar opts v - LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' - LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' - LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' + LMTrunc v t -> ppLlvmType t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMBitc v t -> ppLlvmType t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMPtoI v t -> ppLlvmType t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd") LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub") +{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-} +{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc +pprSpecialStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc pprSpecialStatic opts stat = case stat of - LMBitc v t -> ppr (pLower t) + LMBitc v t -> ppLlvmType (pLower t) <> text ", bitcast (" - <> ppStatic opts v <> text " to " <> ppr t + <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' - LMStaticPointer x -> ppr (pLower $ getVarType x) + LMStaticPointer x -> ppLlvmType (pLower $ getVarType x) <> comma <+> ppStatic opts stat _ -> ppStatic opts stat +{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-} +{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc - -> SDoc -> SDoc +pprStaticArith :: IsLine doc => LlvmCgConfig -> LlvmStatic -> LlvmStatic -> doc -> doc -> SDoc -> doc pprStaticArith opts s1 s2 int_op float_op op_name = let ty1 = getStatType s1 op = if isFloat ty1 then float_op else int_op in if ty1 == getStatType s2 - then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen + then ppLlvmType ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen else pprPanic "pprStaticArith" $ op_name <> text " with different types! s1: " <> ppStatic opts s1 <> text", s2: " <> ppStatic opts s2 +{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc -> SDoc -> SDoc #-} +{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> HLine -> HLine -> SDoc -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -------------------------------------------------------------------------------- @@ -606,9 +723,13 @@ -------------------------------------------------------------------------------- -- | Blank line. -newLine :: SDoc +newLine :: IsDoc doc => doc newLine = empty +{-# SPECIALIZE newLine :: SDoc #-} +{-# SPECIALIZE newLine :: HDoc #-} -- | Exclamation point. -exclamation :: SDoc +exclamation :: IsLine doc => doc exclamation = char '!' +{-# SPECIALIZE exclamation :: SDoc #-} +{-# SPECIALIZE exclamation :: HLine #-} diff --git a/compiler/GHC/Llvm/Syntax.hs b/compiler/GHC/Llvm/Syntax.hs --- a/compiler/GHC/Llvm/Syntax.hs +++ b/compiler/GHC/Llvm/Syntax.hs @@ -10,6 +10,7 @@ import GHC.Llvm.Types import GHC.Types.Unique +import GHC.Cmm.MachOp ( FMASign(..) ) -- | Block labels type LlvmBlockId = Unique @@ -150,7 +151,7 @@ * value: Variable/Constant to store. * ptr: Location to store the value in -} - | Store LlvmVar LlvmVar LMAlign + | Store LlvmVar LlvmVar LMAlign [MetaAnnot] {- | Multiway branch @@ -186,11 +187,6 @@ -} | Nop - {- | - A LLVM statement with metadata attached to it. - -} - | MetaStmt [MetaAnnot] LlvmStatement - deriving (Eq) @@ -342,6 +338,8 @@ expression is executed. -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + + | FMAOp FMASign LlvmVar LlvmVar LlvmVar {- | A LLVM expression with metadata attached to it. 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 @@ -1,6 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +-- Workaround for #21972. It can be removed once the minimal bootstrapping +-- compiler has a fix for this bug. +#if defined(darwin_HOST_OS) +{-# OPTIONS_GHC -fno-asm-shortcutting #-} +#endif + -------------------------------------------------------------------------------- -- | The LLVM Type System. -- @@ -61,28 +68,30 @@ deriving (Eq) instance Outputable LlvmType where - ppr = ppType + ppr = ppLlvmType -ppType :: LlvmType -> SDoc -ppType t = case t of - LMInt size -> char 'i' <> ppr size +ppLlvmType :: IsLine doc => LlvmType -> doc +ppLlvmType t = case t of + LMInt size -> char 'i' <> int size LMFloat -> text "float" LMDouble -> text "double" LMFloat80 -> text "x86_fp80" LMFloat128 -> text "fp128" - LMPointer x -> ppr x <> char '*' - LMArray nr tp -> char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' - LMVector nr tp -> char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' + LMPointer x -> ppLlvmType x <> char '*' + LMArray nr tp -> char '[' <> int nr <> text " x " <> ppLlvmType tp <> char ']' + LMVector nr tp -> char '<' <> int nr <> text " x " <> ppLlvmType tp <> char '>' LMLabel -> text "label" LMVoid -> text "void" - LMStruct tys -> text "<{" <> ppCommaJoin tys <> text "}>" - LMStructU tys -> text "{" <> ppCommaJoin tys <> text "}" + LMStruct tys -> text "<{" <> ppCommaJoin ppLlvmType tys <> text "}>" + LMStructU tys -> text "{" <> ppCommaJoin ppLlvmType tys <> text "}" LMMetadata -> text "metadata" LMAlias (s,_) -> char '%' <> ftext s LMFunction (LlvmFunctionDecl _ _ _ r varg p _) - -> ppr r <+> lparen <> ppParams varg p <> rparen + -> ppLlvmType r <+> lparen <> ppParams varg p <> rparen +{-# SPECIALIZE ppLlvmType :: LlvmType -> SDoc #-} +{-# SPECIALIZE ppLlvmType :: LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc +ppParams :: IsLine doc => LlvmParameterListType -> [LlvmParameter] -> doc ppParams varg p = let varg' = case varg of VarArgs | null args -> text "..." @@ -90,7 +99,9 @@ _otherwise -> text "" -- by default we don't print param attributes args = map fst p - in ppCommaJoin args <> varg' + in ppCommaJoin ppLlvmType args <> varg' +{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc #-} +{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString @@ -337,14 +348,6 @@ } deriving (Eq) -instance Outputable LlvmFunctionDecl where - ppr (LlvmFunctionDecl n l c r varg p a) - = let align = case a of - Just a' -> text " align " <> ppr a' - Nothing -> empty - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> - lparen <> ppParams varg p <> rparen <> align - type LlvmFunctionDecls = [LlvmFunctionDecl] type LlvmParameter = (LlvmType, [LlvmParamAttr]) @@ -385,15 +388,20 @@ deriving (Eq) instance Outputable LlvmParamAttr where - ppr ZeroExt = text "zeroext" - ppr SignExt = text "signext" - ppr InReg = text "inreg" - ppr ByVal = text "byval" - ppr SRet = text "sret" - ppr NoAlias = text "noalias" - ppr NoCapture = text "nocapture" - ppr Nest = text "nest" + ppr = ppLlvmParamAttr +ppLlvmParamAttr :: IsLine doc => LlvmParamAttr -> doc +ppLlvmParamAttr ZeroExt = text "zeroext" +ppLlvmParamAttr SignExt = text "signext" +ppLlvmParamAttr InReg = text "inreg" +ppLlvmParamAttr ByVal = text "byval" +ppLlvmParamAttr SRet = text "sret" +ppLlvmParamAttr NoAlias = text "noalias" +ppLlvmParamAttr NoCapture = text "nocapture" +ppLlvmParamAttr Nest = text "nest" +{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> SDoc #-} +{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Llvm Function Attributes. -- -- Function attributes are set to communicate additional information about a @@ -473,21 +481,26 @@ deriving (Eq) instance Outputable LlvmFuncAttr where - ppr AlwaysInline = text "alwaysinline" - ppr InlineHint = text "inlinehint" - ppr NoInline = text "noinline" - ppr OptSize = text "optsize" - ppr NoReturn = text "noreturn" - ppr NoUnwind = text "nounwind" - ppr ReadNone = text "readnone" - ppr ReadOnly = text "readonly" - ppr Ssp = text "ssp" - ppr SspReq = text "ssqreq" - ppr NoRedZone = text "noredzone" - ppr NoImplicitFloat = text "noimplicitfloat" - ppr Naked = text "naked" + ppr = ppLlvmFuncAttr +ppLlvmFuncAttr :: IsLine doc => LlvmFuncAttr -> doc +ppLlvmFuncAttr AlwaysInline = text "alwaysinline" +ppLlvmFuncAttr InlineHint = text "inlinehint" +ppLlvmFuncAttr NoInline = text "noinline" +ppLlvmFuncAttr OptSize = text "optsize" +ppLlvmFuncAttr NoReturn = text "noreturn" +ppLlvmFuncAttr NoUnwind = text "nounwind" +ppLlvmFuncAttr ReadNone = text "readnone" +ppLlvmFuncAttr ReadOnly = text "readonly" +ppLlvmFuncAttr Ssp = text "ssp" +ppLlvmFuncAttr SspReq = text "ssqreq" +ppLlvmFuncAttr NoRedZone = text "noredzone" +ppLlvmFuncAttr NoImplicitFloat = text "noimplicitfloat" +ppLlvmFuncAttr Naked = text "naked" +{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> SDoc #-} +{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Different types to call a function. data LlvmCallType -- | Normal call, allocate a new stack frame. @@ -533,14 +546,19 @@ deriving (Eq) instance Outputable LlvmCallConvention where - ppr CC_Ccc = text "ccc" - ppr CC_Fastcc = text "fastcc" - ppr CC_Coldcc = text "coldcc" - ppr CC_Ghc = text "ghccc" - ppr (CC_Ncc i) = text "cc " <> ppr i - ppr CC_X86_Stdcc = text "x86_stdcallcc" + ppr = ppLlvmCallConvention +ppLlvmCallConvention :: IsLine doc => LlvmCallConvention -> doc +ppLlvmCallConvention CC_Ccc = text "ccc" +ppLlvmCallConvention CC_Fastcc = text "fastcc" +ppLlvmCallConvention CC_Coldcc = text "coldcc" +ppLlvmCallConvention CC_Ghc = text "ghccc" +ppLlvmCallConvention (CC_Ncc i) = text "cc " <> int i +ppLlvmCallConvention CC_X86_Stdcc = text "x86_stdcallcc" +{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> SDoc #-} +{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Functions can have a fixed amount of parameters, or a variable amount. data LlvmParameterListType -- Fixed amount of arguments. @@ -597,18 +615,23 @@ deriving (Eq) instance Outputable LlvmLinkageType where - ppr Internal = text "internal" - ppr LinkOnce = text "linkonce" - ppr Weak = text "weak" - ppr Appending = text "appending" - ppr ExternWeak = text "extern_weak" - -- ExternallyVisible does not have a textual representation, it is - -- the linkage type a function resolves to if no other is specified - -- in Llvm. - ppr ExternallyVisible = empty - ppr External = text "external" - ppr Private = text "private" + ppr = ppLlvmLinkageType +ppLlvmLinkageType :: IsLine doc => LlvmLinkageType -> doc +ppLlvmLinkageType Internal = text "internal" +ppLlvmLinkageType LinkOnce = text "linkonce" +ppLlvmLinkageType Weak = text "weak" +ppLlvmLinkageType Appending = text "appending" +ppLlvmLinkageType ExternWeak = text "extern_weak" +-- ExternallyVisible does not have a textual representation, it is +-- the linkage type a function resolves to if no other is specified +-- in Llvm. +ppLlvmLinkageType ExternallyVisible = empty +ppLlvmLinkageType External = text "external" +ppLlvmLinkageType Private = text "private" +{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> SDoc #-} +{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- ----------------------------------------------------------------------------- -- * LLVM Operations -- @@ -645,26 +668,31 @@ deriving (Eq) instance Outputable LlvmMachOp where - ppr LM_MO_Add = text "add" - ppr LM_MO_Sub = text "sub" - ppr LM_MO_Mul = text "mul" - ppr LM_MO_UDiv = text "udiv" - ppr LM_MO_SDiv = text "sdiv" - ppr LM_MO_URem = text "urem" - ppr LM_MO_SRem = text "srem" - ppr LM_MO_FAdd = text "fadd" - ppr LM_MO_FSub = text "fsub" - ppr LM_MO_FMul = text "fmul" - ppr LM_MO_FDiv = text "fdiv" - ppr LM_MO_FRem = text "frem" - ppr LM_MO_Shl = text "shl" - ppr LM_MO_LShr = text "lshr" - ppr LM_MO_AShr = text "ashr" - ppr LM_MO_And = text "and" - ppr LM_MO_Or = text "or" - ppr LM_MO_Xor = text "xor" + ppr = ppLlvmMachOp +ppLlvmMachOp :: IsLine doc => LlvmMachOp -> doc +ppLlvmMachOp LM_MO_Add = text "add" +ppLlvmMachOp LM_MO_Sub = text "sub" +ppLlvmMachOp LM_MO_Mul = text "mul" +ppLlvmMachOp LM_MO_UDiv = text "udiv" +ppLlvmMachOp LM_MO_SDiv = text "sdiv" +ppLlvmMachOp LM_MO_URem = text "urem" +ppLlvmMachOp LM_MO_SRem = text "srem" +ppLlvmMachOp LM_MO_FAdd = text "fadd" +ppLlvmMachOp LM_MO_FSub = text "fsub" +ppLlvmMachOp LM_MO_FMul = text "fmul" +ppLlvmMachOp LM_MO_FDiv = text "fdiv" +ppLlvmMachOp LM_MO_FRem = text "frem" +ppLlvmMachOp LM_MO_Shl = text "shl" +ppLlvmMachOp LM_MO_LShr = text "lshr" +ppLlvmMachOp LM_MO_AShr = text "ashr" +ppLlvmMachOp LM_MO_And = text "and" +ppLlvmMachOp LM_MO_Or = text "or" +ppLlvmMachOp LM_MO_Xor = text "xor" +{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> SDoc #-} +{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Llvm compare operations. data LlvmCmpOp = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) @@ -689,24 +717,29 @@ deriving (Eq) instance Outputable LlvmCmpOp where - ppr LM_CMP_Eq = text "eq" - ppr LM_CMP_Ne = text "ne" - ppr LM_CMP_Ugt = text "ugt" - ppr LM_CMP_Uge = text "uge" - ppr LM_CMP_Ult = text "ult" - ppr LM_CMP_Ule = text "ule" - ppr LM_CMP_Sgt = text "sgt" - ppr LM_CMP_Sge = text "sge" - ppr LM_CMP_Slt = text "slt" - ppr LM_CMP_Sle = text "sle" - ppr LM_CMP_Feq = text "oeq" - ppr LM_CMP_Fne = text "une" - ppr LM_CMP_Fgt = text "ogt" - ppr LM_CMP_Fge = text "oge" - ppr LM_CMP_Flt = text "olt" - ppr LM_CMP_Fle = text "ole" + ppr = ppLlvmCmpOp +ppLlvmCmpOp :: IsLine doc => LlvmCmpOp -> doc +ppLlvmCmpOp LM_CMP_Eq = text "eq" +ppLlvmCmpOp LM_CMP_Ne = text "ne" +ppLlvmCmpOp LM_CMP_Ugt = text "ugt" +ppLlvmCmpOp LM_CMP_Uge = text "uge" +ppLlvmCmpOp LM_CMP_Ult = text "ult" +ppLlvmCmpOp LM_CMP_Ule = text "ule" +ppLlvmCmpOp LM_CMP_Sgt = text "sgt" +ppLlvmCmpOp LM_CMP_Sge = text "sge" +ppLlvmCmpOp LM_CMP_Slt = text "slt" +ppLlvmCmpOp LM_CMP_Sle = text "sle" +ppLlvmCmpOp LM_CMP_Feq = text "oeq" +ppLlvmCmpOp LM_CMP_Fne = text "une" +ppLlvmCmpOp LM_CMP_Fgt = text "ogt" +ppLlvmCmpOp LM_CMP_Fge = text "oge" +ppLlvmCmpOp LM_CMP_Flt = text "olt" +ppLlvmCmpOp LM_CMP_Fle = text "ole" +{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> SDoc #-} +{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Llvm cast operations. data LlvmCastOp = LM_Trunc -- ^ Integer truncate @@ -724,19 +757,23 @@ deriving (Eq) instance Outputable LlvmCastOp where - ppr LM_Trunc = text "trunc" - ppr LM_Zext = text "zext" - ppr LM_Sext = text "sext" - ppr LM_Fptrunc = text "fptrunc" - ppr LM_Fpext = text "fpext" - ppr LM_Fptoui = text "fptoui" - ppr LM_Fptosi = text "fptosi" - ppr LM_Uitofp = text "uitofp" - ppr LM_Sitofp = text "sitofp" - ppr LM_Ptrtoint = text "ptrtoint" - ppr LM_Inttoptr = text "inttoptr" - ppr LM_Bitcast = text "bitcast" + ppr = ppLlvmCastOp +ppLlvmCastOp :: IsLine doc => LlvmCastOp -> doc +ppLlvmCastOp LM_Trunc = text "trunc" +ppLlvmCastOp LM_Zext = text "zext" +ppLlvmCastOp LM_Sext = text "sext" +ppLlvmCastOp LM_Fptrunc = text "fptrunc" +ppLlvmCastOp LM_Fpext = text "fpext" +ppLlvmCastOp LM_Fptoui = text "fptoui" +ppLlvmCastOp LM_Fptosi = text "fptosi" +ppLlvmCastOp LM_Uitofp = text "uitofp" +ppLlvmCastOp LM_Sitofp = text "sitofp" +ppLlvmCastOp LM_Ptrtoint = text "ptrtoint" +ppLlvmCastOp LM_Inttoptr = text "inttoptr" +ppLlvmCastOp LM_Bitcast = text "bitcast" +{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> SDoc #-} +{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- * Floating point conversion @@ -747,7 +784,7 @@ -- regardless of underlying architecture. -- -- See Note [LLVM Float Types]. -ppDouble :: Platform -> Double -> SDoc +ppDouble :: IsLine doc => Platform -> Double -> doc ppDouble platform d = let bs = doubleToBytes d hex d' = case showHex d' "" of @@ -761,6 +798,8 @@ LittleEndian -> reverse str = map toUpper $ concat $ fixEndian $ map hex bs in text "0x" <> text str +{-# SPECIALIZE ppDouble :: Platform -> Double -> SDoc #-} +{-# SPECIALIZE ppDouble :: Platform -> Double -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -787,16 +826,22 @@ {-# NOINLINE widenFp #-} widenFp = float2Double -ppFloat :: Platform -> Float -> SDoc +ppFloat :: IsLine doc => Platform -> Float -> doc ppFloat platform = ppDouble platform . widenFp +{-# SPECIALIZE ppFloat :: Platform -> Float -> SDoc #-} +{-# SPECIALIZE ppFloat :: Platform -> Float -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- -ppCommaJoin :: (Outputable a) => [a] -> SDoc -ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) +ppCommaJoin :: IsLine doc => (a -> doc) -> [a] -> doc +ppCommaJoin ppr strs = hsep $ punctuate comma (map ppr strs) +{-# SPECIALIZE ppCommaJoin :: (a -> SDoc) -> [a] -> SDoc #-} +{-# SPECIALIZE ppCommaJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppSpaceJoin :: (Outputable a) => [a] -> SDoc -ppSpaceJoin strs = hsep (map ppr strs) +ppSpaceJoin :: IsLine doc => (a -> doc) -> [a] -> doc +ppSpaceJoin ppr strs = hsep (map ppr strs) +{-# SPECIALIZE ppSpaceJoin :: (a -> SDoc) -> [a] -> SDoc #-} +{-# SPECIALIZE ppSpaceJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -55,6 +55,7 @@ , module GHC.Types.Unique.Supply , module GHC.Data.FastString , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins + , module GHC.Tc.Errors.Hole.Plugin -- for hole-fit plugins , module GHC.Unit.Module.ModGuts , module GHC.Unit.Module.ModSummary , module GHC.Unit.Module.ModIface @@ -148,6 +149,7 @@ import GHC.Types.Name.Cache ( NameCache ) import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Errors.Hole.Plugin -- For parse result plugins import GHC.Parser.Errors.Types ( PsWarning, PsError ) 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 @@ -26,7 +26,10 @@ rnMethodBinds, renameSigs, rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, makeMiniFixityEnv, MiniFixityEnv, - HsSigCtxt(..) + HsSigCtxt(..), + + -- Utility for hs-boot files + rejectBootDecls ) where import GHC.Prelude @@ -42,13 +45,13 @@ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( mapFvRn - , checkDupRdrNames, checkDupRdrNamesN + , checkDupRdrNames , warnUnusedLocalBinds , warnForallIdentifier , checkUnusedRecordWildcard , checkDupAndShadowedNames, bindLocalNamesFV , addNoNestedForallsContextsErr, checkInferredVars ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Unit.Module import GHC.Types.Error import GHC.Types.FieldLabel @@ -56,6 +59,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader ( RdrName, rdrNameOcc ) +import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc import GHC.Data.List.SetOps ( findDupsEq ) import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) @@ -72,8 +76,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition, sortBy ) +import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) ) {- @@ -200,10 +203,20 @@ = do { topBinds <- rnTopBindsLHS fix_env binds ; case topBinds of ValBinds x mbinds sigs -> - do { mapM_ bindInHsBootFileErr mbinds + do { rejectBootDecls HsBoot BootBindsPs (bagToList $ mbinds) ; pure (ValBinds x emptyBag sigs) } _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) } +rejectBootDecls :: HsBootOrSig + -> (NonEmpty (LocatedA decl) -> BadBootDecls) + -> [LocatedA decl] + -> TcM () +rejectBootDecls _ _ [] = return () +rejectBootDecls hsc_src what (decl@(L loc _) : decls) + = addErrAt (locA loc) + $ TcRnIllegalHsBootOrSigDecl hsc_src + (what $ decl :| decls) + rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. @@ -529,7 +542,7 @@ = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind ; return (PatSynBind x bind', name, fvs) } -rnBind _ b = pprPanic "rnBind" (ppr b) +rnBind _ (VarBind { var_ext = x }) = dataConCantHappen x -- See Note [Pattern bindings that bind no variables] isOkNoBindPattern :: LPat GhcRn -> Bool @@ -690,17 +703,11 @@ Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addErrAt name_loc (dupFixityDecl loc' name) + addErrAt name_loc (TcRnMultipleFixityDecls loc' name) ; return env} } -dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage -dupFixityDecl loc rdr_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] - {- ********************************************************************* * * Pattern synonym bindings @@ -716,7 +723,7 @@ , psb_dir = dir }) -- invariant: no free vars here when it's a FunBind = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms - ; unless pattern_synonym_ok (addErr patternSynonymErr) + ; unless pattern_synonym_ok (addErr TcRnIllegalPatternSynonymDecl) ; let scoped_tvs = sig_fn name ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ @@ -726,7 +733,7 @@ -- from the left-hand side case details of PrefixCon _ vars -> - do { checkDupRdrNamesN vars + do { checkDupRdrNames vars ; names <- mapM lookupPatSynBndr vars ; return ( (pat', PrefixCon noTypeArgs names) , mkFVs (map unLoc names)) } @@ -785,11 +792,6 @@ -- See Note [Renaming pattern synonym variables] lookupPatSynBndr = wrapLocMA lookupLocalOccRn - patternSynonymErr :: TcRnMessage - patternSynonymErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal pattern synonym declaration") - 2 (text "Use -XPatternSynonyms to enable this extension") {- Note [Renaming pattern synonym variables] @@ -889,7 +891,7 @@ -- * the default method bindings in a class decl -- * the method bindings in an instance decl rnMethodBinds is_cls_decl cls ktv_names binds sigs - = do { checkDupRdrNamesN (collectMethodBinders binds) + = do { checkDupRdrNames (collectMethodBinders binds) -- Check that the same method is not given twice in the -- same instance decl instance C T where -- f x = ... @@ -980,18 +982,11 @@ -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ what <+> text "not allowed in" <+> decl_sort - , nest 2 (ppr bind) ] + = do { addErrAt (locA loc) $ TcRnIllegalClassBinding decl_sort bind ; return rest } where - decl_sort | is_cls_decl = text "class declaration:" - | otherwise = text "instance declaration:" - what = case bind of - PatBind {} -> text "Pattern bindings (except simple variables)" - PatSynBind {} -> text "Pattern synonyms" - -- Associated pattern synonyms are not implemented yet - _ -> pprPanic "rnMethodBind" (ppr bind) + decl_sort | is_cls_decl = ClassDeclSort + | otherwise = InstanceDeclSort {- ************************************************************************ @@ -1046,7 +1041,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ - addErr (defaultSigErr sig) + addErr (TcRnUnexpectedDefaultSig sig) ; mapM_ warnForallIdentifier vs ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty @@ -1057,18 +1052,17 @@ <+> quotes (ppr v1)) renameSig _ (SpecInstSig (_, src) ty) - = do { checkInferredVars doc inf_msg ty + = do { checkInferredVars doc ty ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty -- Check if there are any nested `forall`s or contexts, which are -- illegal in the type of an instance declaration (see -- Note [No nested foralls or contexts in instance types] in -- GHC.Hs.Type). - ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") + ; addNoNestedForallsContextsErr doc NFC_Specialize (getLHsInstDeclHead new_ty) ; return (SpecInstSig (noAnn, src) new_ty,fvs) } where doc = SpecInstSigCtx - 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) @@ -1120,16 +1114,11 @@ this_mod <- fmap tcg_mod getGblEnv unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ -- Why 'any'? See Note [Orphan COMPLETE pragmas] - addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError + addErrCtxt (text "In" <+> ppr sig) $ failWithTc TcRnOrphanCompletePragma return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs) - where - orphanError :: TcRnMessage - orphanError = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Orphan COMPLETE pragmas not supported" $$ - text "A COMPLETE pragma must mention at least one data constructor" $$ - text "or pattern synonym defined in the same module." + {- Note [Orphan COMPLETE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1233,7 +1222,7 @@ checkDupMinimalSigs :: [LSig GhcPs] -> RnM () checkDupMinimalSigs sigs = case filter isMinimalLSig sigs of - minSigs@(_:_:_) -> dupMinimalSigErr minSigs + sig1 : sig2 : otherSigs -> dupMinimalSigErr sig1 sig2 otherSigs _ -> return () {- @@ -1283,7 +1272,7 @@ -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin }) -- see Note [Empty MatchGroups] - = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt)) + = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) } where @@ -1314,30 +1303,7 @@ ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) } -emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage -emptyCaseErr ctxt = mkTcRnUnknownMessage $ mkPlainError noHints $ message ctxt - where - pp_ctxt :: HsMatchContext GhcRn -> SDoc - pp_ctxt c = case c of - CaseAlt -> text "case expression" - LamCaseAlt LamCase -> text "\\case expression" - ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command" - ArrowMatchCtxt ArrowCaseAlt -> text "case command" - ArrowMatchCtxt KappaExpr -> text "kappa abstraction" - _ -> text "(unexpected)" - <+> pprMatchContextNoun c - message :: HsMatchContext GhcRn -> SDoc - message (LamCaseAlt LamCases) = lcases_msg <+> text "expression" - message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) = - lcases_msg <+> text "command" - message ctxt = - hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt) - 2 (text "Use EmptyCase to allow this") - - lcases_msg = - text "Empty list of alternatives is not allowed in \\cases" - {- ************************************************************************ * * @@ -1373,9 +1339,7 @@ rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') $ - let diag = mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards') - in addDiagnostic diag + addDiagnostic (nonStdGuardErr guards') ; return (GRHS noAnn guards' rhs', fvs) } where @@ -1427,44 +1391,18 @@ -} dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () -dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Duplicate" <+> what_it_is - <> text "s for" <+> quotes (ppr name) - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest - $ map (getLocA . fst) - $ toList pairs) - ] - where - what_it_is = hsSigDoc sig +dupSigDeclErr pairs@((L loc _, _) :| _) + = addErrAt (locA loc) $ TcRnDuplicateSigDecl pairs misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] - -defaultSigErr :: Sig GhcPs -> TcRnMessage -defaultSigErr sig = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] - -bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM () -bindInHsBootFileErr (L loc _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Bindings in hs-boot files are not allowed" ] + = addErrAt (locA loc) $ TcRnMisplacedSigDecl sig nonStdGuardErr :: (Outputable body, Anno (Stmt GhcRn body) ~ SrcSpanAnnA) - => [LStmtLR GhcRn GhcRn body] -> SDoc -nonStdGuardErr guards - = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") - 4 (interpp'SP guards) + => [LStmtLR GhcRn GhcRn body] -> TcRnMessage +nonStdGuardErr guards = TcRnNonStdGuards (NonStandardGuards guards) -dupMinimalSigErr :: [LSig GhcPs] -> RnM () -dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs) - , text "Combine alternative minimal complete definitions with `|'" ] -dupMinimalSigErr [] = panic "dupMinimalSigErr" +dupMinimalSigErr :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> RnM () +dupMinimalSigErr sig1 sig2 otherSigs + = addErrAt (getLocA sig1) $ TcRnDuplicateMinimalSig sig1 sig2 otherSigs diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs --- a/compiler/GHC/Rename/Doc.hs +++ b/compiler/GHC/Rename/Doc.hs @@ -8,8 +8,6 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Tc.Utils.Monad (getGblEnv) -import GHC.Types.Avail -import GHC.Rename.Env rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn) rnLHsDoc = traverse rnHsDoc @@ -37,10 +35,10 @@ pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids)) rnHsDocIdentifiers :: GlobalRdrEnv - -> [Located RdrName] - -> [Located Name] -rnHsDocIdentifiers gre ns = concat - [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre) + -> [Located RdrName] + -> [Located Name] +rnHsDocIdentifiers gre_env ns = + [ L l $ greName gre | L l rdr_name <- ns - , c <- dataTcOccs rdr_name + , gre <- lookupGRE gre_env (LookupOccName (rdrNameOcc rdr_name) AllRelevantGREs) ] 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 @@ -1,2095 +1,2394 @@ - -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 - -GHC.Rename.Env contains functions which convert RdrNames into Names. - --} - -module GHC.Rename.Env ( - newTopSrcBinder, - - lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn, - lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, - - lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, - lookupLocatedOccRnNone, - lookupOccRn, lookupOccRn_maybe, - lookupLocalOccRn_maybe, lookupInfoOccRn, - lookupLocalOccThLvl_maybe, lookupLocalOccRn, - lookupTypeOccRn, - lookupGlobalOccRn, lookupGlobalOccRn_maybe, - - AmbiguousResult(..), - lookupExprOccRn, - lookupRecFieldOcc, - lookupRecFieldOcc_update, - - ChildLookupResult(..), - lookupSubBndrOcc_helper, - combineChildLookupResult, -- Called by lookupChildrenExport - - HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN, - lookupSigCtxtOccRn, lookupSigCtxtOccRnN, - - lookupInstDeclBndr, lookupFamInstName, - lookupConstructorFields, - - lookupGreAvailRn, - - -- Rebindable Syntax - lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames, - lookupSyntaxName, - lookupIfThenElse, - - -- QualifiedDo - lookupQualifiedDoExpr, lookupQualifiedDo, - lookupQualifiedDoName, lookupNameWithQualifier, - - -- Constructing usage information - addUsedGRE, addUsedGREs, addUsedDataCons, - - - - dataTcOccs, --TODO: Move this somewhere, into utils? - - ) where - -import GHC.Prelude - -import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) -import GHC.Iface.Env -import GHC.Hs -import GHC.Types.Name.Reader -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Builtin.Types -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Avail -import GHC.Types.Hint -import GHC.Types.Error -import GHC.Unit.Module -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Warnings ( WarningTxt ) -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Builtin.Names( rOOT_MAIN ) -import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) -import GHC.Types.SrcLoc as SrcLoc -import GHC.Utils.Outputable as Outputable -import GHC.Types.Unique.Set ( uniqSetAny ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Data.Maybe -import GHC.Driver.Session -import GHC.Data.FastString -import Control.Monad -import GHC.Data.List.SetOps ( minusList ) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Unbound -import GHC.Rename.Utils -import qualified Data.Semigroup as Semi -import Data.Either ( partitionEithers ) -import Data.List ( find ) -import qualified Data.List.NonEmpty as NE -import Control.Arrow ( first ) -import GHC.Types.FieldLabel -import GHC.Data.Bag -import GHC.Types.PkgQual -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -{- -********************************************************* -* * - Source-code binders -* * -********************************************************* - -Note [Signature lazy interface loading] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC's lazy interface loading can be a bit confusing, so this Note is an -empirical description of what happens in one interesting case. When -compiling a signature module against an its implementation, we do NOT -load interface files associated with its names until after the type -checking phase. For example: - - module ASig where - data T - f :: T -> T - -Suppose we compile this with -sig-of "A is ASig": - - module B where - data T = T - f T = T - - module A(module B) where - import B - -During type checking, we'll load A.hi because we need to know what the -RdrEnv for the module is, but we DO NOT load the interface for B.hi! -It's wholly unnecessary: our local definition 'data T' in ASig is all -the information we need to finish type checking. This is contrast to -type checking of ordinary Haskell files, in which we would not have the -local definition "data T" and would need to consult B.hi immediately. -(Also, this situation never occurs for hs-boot files, since you're not -allowed to reexport from another module.) - -After type checking, we then check that the types we provided are -consistent with the backing implementation (in checkHiBootOrHsigIface). -At this point, B.hi is loaded, because we need something to compare -against. - -I discovered this behavior when trying to figure out why type class -instances for Data.Map weren't in the EPS when I was type checking a -test very much like ASig (sigof02dm): the associated interface hadn't -been loaded yet! (The larger issue is a moot point, since an instance -declared in a signature can never be a duplicate.) - -This behavior might change in the future. Consider this -alternate module B: - - module B where - {-# DEPRECATED T, f "Don't use" #-} - data T = T - f T = T - -One might conceivably want to report deprecation warnings when compiling -ASig with -sig-of B, in which case we need to look at B.hi to find the -deprecation warnings during renaming. At the moment, you don't get any -warning until you use the identifier further downstream. This would -require adjusting addUsedGRE so that during signature compilation, -we do not report deprecation warnings for LocalDef. See also -Note [Handling of deprecations] --} - -newTopSrcBinder :: LocatedN RdrName -> RnM Name -newTopSrcBinder (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = -- This is here to catch - -- (a) Exact-name binders created by Template Haskell - -- (b) The PrelBase defn of (say) [] and similar, for which - -- the parser reads the special syntax and returns an Exact RdrName - -- We are at a binding site for the name, so check first that it - -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like - -- data T = (,) Int Int - -- unless we are in GHC.Tup - if isExternalName name then - do { this_mod <- getModule - ; unless (this_mod == nameModule name) - (addErrAt (locA loc) (badOrigBinding rdr_name)) - ; return name } - else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" - do { this_mod <- getModule - ; externaliseName this_mod name } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { this_mod <- getModule - ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (addErrAt (locA loc) (badOrigBinding rdr_name)) - -- When reading External Core we get Orig names as binders, - -- but they should agree with the module gotten from the monad - -- - -- We can get built-in syntax showing up here too, sadly. If you type - -- data T = (,,,) - -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon - -- uses setRdrNameSpace to make it into a data constructors. At that point - -- the nice Exact name for the TyCon gets swizzled to an Orig name. - -- Hence the badOrigBinding error message. - -- - - -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore - -- because External Core has been removed but we instead have some similar logic for - -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id. - - -- Except for the ":Main.main = ..." definition inserted into - -- the Main module; ugh! - - -- Because of this latter case, we call newGlobalBinder with a module from - -- the RdrName, not from the environment. In principle, it'd be fine to - -- have an arbitrary mixture of external core definitions in a single module, - -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ (locA loc) } - - | otherwise - = do { when (isQual rdr_name) - (addErrAt (locA loc) (badQualBndrErr rdr_name)) - -- Binders should not be qualified; if they are, and with a different - -- module name, we get a confusing "M.T is not in scope" error later - - ; stage <- getStage - ; if isBrackStage stage then - -- We are inside a TH bracket, so make an *Internal* name - -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names - do { uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } - else - do { this_mod <- getModule - ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc)) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) } - } - -{- -********************************************************* -* * - Source code occurrences -* * -********************************************************* - -Looking up a name in the GHC.Rename.Env. - -Note [Type and class operator definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to reject all of these unless we have -XTypeOperators (#3265) - data a :*: b = ... - class a :*: b where ... - data (:*:) a b = .... - class (:*:) a b where ... -The latter two mean that we are not just looking for a -*syntactically-infix* declaration, but one that uses an operator -OccName. We use OccName.isSymOcc to detect that case, which isn't -terribly efficient, but there seems to be no better way. --} - --- Can be made to not be exposed --- Only used unwrapped in rnAnnProvenance -lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name --- Look up a top-level source-code binder. We may be looking up an unqualified 'f', --- and there may be several imported 'f's too, which must not confuse us. --- For example, this is OK: --- import Foo( f ) --- infix 9 f -- The 'f' here does not need to be qualified --- f x = x -- Nor here, of course --- So we have to filter out the non-local ones. --- --- A separate function (importsFromLocalDecls) reports duplicate top level --- decls, so here it's safe just to choose an arbitrary one. -lookupTopBndrRn which_suggest rdr_name = - lookupExactOrOrig rdr_name id $ - do { -- Check for operators in type or class declarations - -- See Note [Type and class operator definitions] - let occ = rdrNameOcc rdr_name - ; when (isTcOcc occ && isSymOcc occ) - (do { op_ok <- xoptM LangExt.TypeOperators - ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) - - ; env <- getGlobalRdrEnv - ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (greMangledName gre) - _ -> do -- Ambiguous (can't happen) or unbound - traceRn "lookupTopBndrRN fail" (ppr rdr_name) - unboundName (LF which_suggest WL_LocalTop) rdr_name - } - -lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name) -lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor) - -lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name) -lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor) - -lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) -lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything) - -lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name) -lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything) - --- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. --- This never adds an error, but it may return one, see --- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) -lookupExactOcc_either name - | Just thing <- wiredInNameTyThing_maybe name - , Just tycon <- case thing of - ATyCon tc -> Just tc - AConLike (RealDataCon dc) -> Just (dataConTyCon dc) - _ -> Nothing - , Just tupleSort <- tyConTuple_maybe tycon - = do { let tupArity = case tupleSort of - -- Unboxed tuples have twice as many arguments because of the - -- 'RuntimeRep's (#17837) - UnboxedTuple -> tyConArity tycon `div` 2 - _ -> tyConArity tycon - ; checkTupSize tupArity - ; return (Right name) } - - | isExternalName name - = return (Right name) - - | otherwise - = do { env <- getGlobalRdrEnv - ; let -- See Note [Splicing Exact names] - main_occ = nameOccName name - demoted_occs = case demoteOccName main_occ of - Just occ -> [occ] - Nothing -> [] - gres = [ gre | occ <- main_occ : demoted_occs - , gre <- lookupGlobalRdrEnv env occ - , greMangledName gre == name ] - ; case gres of - [gre] -> return (Right (greMangledName gre)) - - [] -> -- See Note [Splicing Exact names] - do { lcl_env <- getLocalRdrEnv - ; if name `inLocalRdrEnvScope` lcl_env - then return (Right name) - else - do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; th_topnames <- readTcRef th_topnames_var - ; if name `elemNameSet` th_topnames - then return (Right name) - else return (Left (NoExactName name)) - } - } - - gres -> return (Left (SameName gres)) -- Ugh! See Note [Template Haskell ambiguity] - } - ------------------------------------------------ -lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name --- This is called on the method name on the left-hand side of an --- instance declaration binding. eg. instance Functor T where --- fmap = ... --- ^^^^ called on this --- Regardless of how many unqualified fmaps are in scope, we want --- the one that comes from the Functor class. --- --- Furthermore, note that we take no account of whether the --- name is only in scope qualified. I.e. even if method op is --- in scope as M.op, we still allow plain 'op' on the LHS of --- an instance decl --- --- The "what" parameter says "method" or "associated type", --- depending on what we are looking up -lookupInstDeclBndr cls what rdr - = do { when (isQual rdr) - (addErr (badQualBndrErr rdr)) - -- In an instance decl you aren't allowed - -- to use a qualified name for the method - -- (Although it'd make perfect sense.) - ; mb_name <- lookupSubBndrOcc - False -- False => we don't give deprecated - -- warnings when a deprecated class - -- method is defined. We only warn - -- when it's used - cls doc rdr - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr err) - ; return (mkUnboundNameRdr rdr) } - Right nm -> return nm } - where - doc = what <+> text "of class" <+> quotes (ppr cls) - ------------------------------------------------ -lookupFamInstName :: Maybe Name -> LocatedN RdrName - -> RnM (LocatedN Name) --- Used for TyData and TySynonym family instances only, --- See Note [Family instance binders] -lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind - = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr -lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRnConstr tc_rdr - ------------------------------------------------ -lookupConstructorFields :: Name -> RnM [FieldLabel] --- Look up the fields of a given constructor --- * For constructors from this module, use the record field env, --- which is itself gathered from the (as yet un-typechecked) --- data type decls --- --- * For constructors from imported modules, use the *type* environment --- since imported modules are already compiled, the info is conveniently --- right there - -lookupConstructorFields con_name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod con_name then - do { field_env <- getRecFieldEnv - ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) - ; return (lookupNameEnv field_env con_name `orElse` []) } - else - do { con <- tcLookupConLike con_name - ; traceTc "lookupCF 2" (ppr con) - ; return (conLikeFieldLabels con) } } - - --- In CPS style as `RnM r` is monadic --- Reports an error if the name is an Exact or Orig and it can't find the name --- Otherwise if it is not an Exact or Orig, returns k -lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r -lookupExactOrOrig rdr_name res k - = do { men <- lookupExactOrOrig_base rdr_name - ; case men of - FoundExactOrOrig n -> return (res n) - ExactOrOrigError e -> - do { addErr (mkTcRnNotInScope rdr_name e) - ; return (res (mkUnboundNameRdr rdr_name)) } - NotExactOrOrig -> k } - --- Variant of 'lookupExactOrOrig' that does not report an error --- See Note [Errors in lookup functions] --- Calls k if the name is neither an Exact nor Orig -lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r -lookupExactOrOrig_maybe rdr_name res k - = do { men <- lookupExactOrOrig_base rdr_name - ; case men of - FoundExactOrOrig n -> return (res (Just n)) - ExactOrOrigError _ -> return (res Nothing) - NotExactOrOrig -> k } - -data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact - -- or Orig, but there was an - -- error looking up the Name - | NotExactOrOrig -- ^ The RdrName is neither an Exact nor - -- Orig - --- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' -lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult -lookupExactOrOrig_base rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = cvtEither <$> lookupExactOcc_either n - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ - | otherwise = return NotExactOrOrig - where - cvtEither (Left e) = ExactOrOrigError e - cvtEither (Right n) = FoundExactOrOrig n - - -{- Note [Errors in lookup functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Many of these lookup functions will attach an error if it can't find the Name it -is trying to lookup. However there are also _maybe and _either variants for many -of these functions. - -These variants should *not* attach any errors, as there are -places where we want to attempt looking up a name, but it's not the end of the -world if we don't find it. - -For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple -times for varying names in different namespaces. lookupOccRn_maybe should -therefore never attach an error, instead just return a Nothing. - -For these _maybe/_either variant functions then, avoid calling further lookup -functions that can attach errors and instead call their _maybe/_either -counterparts. --} - ------------------------------------------------ --- | Look up an occurrence of a field in record construction or pattern --- matching (but not update). When the -XDisambiguateRecordFields --- flag is on, take account of the data constructor name to --- disambiguate which field to use. --- --- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. -lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual - -- Just con => use data con to disambiguate - -> RdrName - -> RnM Name -lookupRecFieldOcc mb_con rdr_name - | Just con <- mb_con - , isUnboundName con -- Avoid error cascade - = return (mkUnboundNameRdr rdr_name) - | Just con <- mb_con - = lookupExactOrOrig rdr_name id $ -- See Note [Record field names and Template Haskell] - do { flds <- lookupConstructorFields con - ; env <- getGlobalRdrEnv - ; let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) - mb_field = do fl <- find ((== lbl) . flLabel) flds - -- We have the label, now check it is in scope. If - -- there is a qualifier, use pickGREs to check that - -- the qualifier is correct, and return the filtered - -- GRE so we get import usage right (see #17853). - gre <- lookupGRE_FieldLabel env fl - if isQual rdr_name - then do gre' <- listToMaybe (pickGREs rdr_name [gre]) - return (fl, gre') - else return (fl, gre) - ; case mb_field of - Just (fl, gre) -> do { addUsedGRE True gre - ; return (flSelector fl) } - Nothing -> do { addErr (badFieldConErr con lbl) - ; return (mkUnboundNameRdr rdr_name) } } - - | otherwise -- Can't use the data constructor to disambiguate - = lookupGlobalOccRn' WantBoth rdr_name - -- This use of Global is right as we are looking up a selector, - -- which can only be defined at the top level. - --- | Look up an occurrence of a field in a record update, returning the selector --- name. --- --- Unlike construction and pattern matching with @-XDisambiguateRecordFields@ --- (see 'lookupRecFieldOcc'), there is no data constructor to help disambiguate, --- so this may be ambiguous if the field is in scope multiple times. However we --- ignore non-fields in scope with the same name if @-XDisambiguateRecordFields@ --- is on (see Note [DisambiguateRecordFields for updates]). --- --- Here a field is in scope even if @NoFieldSelectors@ was enabled at its --- definition site (see Note [NoFieldSelectors]). -lookupRecFieldOcc_update - :: DuplicateRecordFields - -> RdrName - -> RnM AmbiguousResult -lookupRecFieldOcc_update dup_fields_ok rdr_name = do - disambig_ok <- xoptM LangExt.DisambiguateRecordFields - let want | disambig_ok = WantField - | otherwise = WantBoth - mr <- lookupGlobalOccRn_overloaded dup_fields_ok want rdr_name - case mr of - Just r -> return r - Nothing -- Try again if we previously looked only for fields, see - -- Note [DisambiguateRecordFields for updates] - | disambig_ok -> do mr' <- lookupGlobalOccRn_overloaded dup_fields_ok WantBoth rdr_name - case mr' of - Just r -> return r - Nothing -> unbound - | otherwise -> unbound - where - unbound = UnambiguousGre . NormalGreName - <$> unboundName (LF WL_RecField WL_Global) rdr_name - - -{- Note [DisambiguateRecordFields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking up record fields in record construction or pattern -matching, we can take advantage of the data constructor name to -resolve fields that would otherwise be ambiguous (provided the --XDisambiguateRecordFields flag is on). - -For example, consider: - - data S = MkS { x :: Int } - data T = MkT { x :: Int } - - e = MkS { x = 3 } - -When we are renaming the occurrence of `x` in `e`, instead of looking -`x` up directly (and finding both fields), lookupRecFieldOcc will -search the fields of `MkS` to find the only possible `x` the user can -mean. - -Of course, we still have to check the field is in scope, using -lookupGRE_FieldLabel. The handling of qualified imports is slightly -subtle: the occurrence may be unqualified even if the field is -imported only qualified (but if the occurrence is qualified, the -qualifier must be correct). For example: - - module A where - data S = MkS { x :: Int } - data T = MkT { x :: Int } - - module B where - import qualified A (S(..)) - import A (T(MkT)) - - e1 = MkT { x = 3 } -- x not in scope, so fail - e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail - e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) - -In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, -lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard -will fail because the field RdrName `B.x` is qualified and pickGREs -rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the -GRE for `A.x` and the guard will succeed because the field RdrName `x` -is unqualified. - - -Note [DisambiguateRecordFields for updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking up record fields in record update, we can take advantage of -the fact that we know we are looking for a field, even though we do not know the -data constructor name (as in Note [DisambiguateRecordFields]), provided the --XDisambiguateRecordFields flag is on. - -For example, consider: - - module N where - f = () - - {-# LANGUAGE DisambiguateRecordFields #-} - module M where - import N (f) - data T = MkT { f :: Int } - t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean - u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' - -This works by lookupRecFieldOcc_update using 'WantField :: FieldsOrSelectors' -when looking up the field name, so that 'filterFieldGREs' will later ignore any -non-fields in scope. Of course, if a record update has two fields in scope with -the same name, it is still ambiguous. - -If we do not find anything when looking only for fields, we try again allowing -fields or non-fields. This leads to a better error message if the user -mistakenly tries to use a non-field name in a record update: - - f = () - e x = x { f = () } - -Unlike with constructors or pattern-matching, we do not allow the module -qualifier to be omitted, because we do not have a data constructor from which to -determine it. - -Note [Record field names and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12130): - - module Foo where - import M - b = $(funny) - - module M(funny) where - data T = MkT { x :: Int } - funny :: Q Exp - funny = [| MkT { x = 3 } |] - -When we splice, `MkT` is not lexically in scope, so -lookupGRE_FieldLabel will fail. But there is no need for -disambiguation anyway, because `x` is an original name, and -lookupGlobalOccRn will find it. --} - - --- | Used in export lists to lookup the children. -lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName - -> RnM ChildLookupResult -lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name - | isUnboundName parent - -- Avoid an error cascade - = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name))) - - | otherwise = do - gre_env <- getGlobalRdrEnv - - let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) - -- Disambiguate the lookup based on the parent information. - -- The remaining GREs are things that we *could* export here, note that - -- this includes things which have `NoParent`. Those are sorted in - -- `checkPatSynParent`. - traceRn "parent" (ppr parent) - traceRn "lookupExportChild original_gres:" (ppr original_gres) - traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent) - case picked_gres original_gres of - NoOccurrence -> - noMatchingParentErr original_gres - UniqueOccurrence g -> - if must_have_parent then noMatchingParentErr original_gres - else checkFld g - DisambiguatedOccurrence g -> - checkFld g - AmbiguousOccurrence gres -> - mkNameClashErr gres - where - -- Convert into FieldLabel if necessary - checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name,gre_par} = do - addUsedGRE warn_if_deprec g - return $ FoundChild gre_par gre_name - - -- Called when we find no matching GREs after disambiguation but - -- there are three situations where this happens. - -- 1. There were none to begin with. - -- 2. None of the matching ones were the parent but - -- a. They were from an overloaded record field so we can report - -- a better error - -- b. The original lookup was actually ambiguous. - -- For example, the case where overloading is off and two - -- record fields are in scope from different record - -- constructors, neither of which is the parent. - noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult - noMatchingParentErr original_gres = do - traceRn "npe" (ppr original_gres) - dup_fields_ok <- xoptM LangExt.DuplicateRecordFields - case original_gres of - [] -> return NameNotFound - [g] -> return $ IncorrectParent parent - (gre_name g) - [p | Just p <- [getParent g]] - gss@(g:gss'@(_:_)) -> - if all isRecFldGRE gss && dup_fields_ok - then return $ - IncorrectParent parent - (gre_name g) - [p | x <- gss, Just p <- [getParent x]] - else mkNameClashErr $ g NE.:| gss' - - mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult - mkNameClashErr gres = do - addNameClashErrRn rdr_name gres - return (FoundChild (gre_par (NE.head gres)) (gre_name (NE.head gres))) - - getParent :: GlobalRdrElt -> Maybe Name - getParent (GRE { gre_par = p } ) = - case p of - ParentIs cur_parent -> Just cur_parent - NoParent -> Nothing - - picked_gres :: [GlobalRdrElt] -> DisambigInfo - -- For Unqual, find GREs that are in scope qualified or unqualified - -- For Qual, find GREs that are in scope with that qualification - picked_gres gres - | isUnqual rdr_name - = mconcat (map right_parent gres) - | otherwise - = mconcat (map right_parent (pickGREs rdr_name gres)) - - right_parent :: GlobalRdrElt -> DisambigInfo - right_parent p - = case getParent p of - Just cur_parent - | parent == cur_parent -> DisambiguatedOccurrence p - | otherwise -> NoOccurrence - Nothing -> UniqueOccurrence p - - --- This domain specific datatype is used to record why we decided it was --- possible that a GRE could be exported with a parent. -data DisambigInfo - = NoOccurrence - -- The GRE could never be exported. It has the wrong parent. - | UniqueOccurrence GlobalRdrElt - -- The GRE has no parent. It could be a pattern synonym. - | DisambiguatedOccurrence GlobalRdrElt - -- The parent of the GRE is the correct parent - | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt) - -- For example, two normal identifiers with the same name are in - -- scope. They will both be resolved to "UniqueOccurrence" and the - -- monoid will combine them to this failing case. - -instance Outputable DisambigInfo where - ppr NoOccurrence = text "NoOccurrence" - ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre - ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre - ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres - -instance Semi.Semigroup DisambigInfo where - -- This is the key line: We prefer disambiguated occurrences to other - -- names. - _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' - DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' - - NoOccurrence <> m = m - m <> NoOccurrence = m - UniqueOccurrence g <> UniqueOccurrence g' - = AmbiguousOccurrence $ g NE.:| [g'] - UniqueOccurrence g <> AmbiguousOccurrence gs - = AmbiguousOccurrence (g `NE.cons` gs) - AmbiguousOccurrence gs <> UniqueOccurrence g' - = AmbiguousOccurrence (g' `NE.cons` gs) - AmbiguousOccurrence gs <> AmbiguousOccurrence gs' - = AmbiguousOccurrence (gs Semi.<> gs') - -instance Monoid DisambigInfo where - mempty = NoOccurrence - mappend = (Semi.<>) - --- Lookup SubBndrOcc can never be ambiguous --- --- Records the result of looking up a child. -data ChildLookupResult - = NameNotFound -- We couldn't find a suitable name - | IncorrectParent Name -- Parent - GreName -- Child we were looking for - [Name] -- List of possible parents - | FoundChild Parent GreName -- We resolved to a child - --- | Specialised version of msum for RnM ChildLookupResult -combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult -combineChildLookupResult [] = return NameNotFound -combineChildLookupResult (x:xs) = do - res <- x - case res of - NameNotFound -> combineChildLookupResult xs - _ -> return res - -instance Outputable ChildLookupResult where - ppr NameNotFound = text "NameNotFound" - ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n - ppr (IncorrectParent p n ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr n, ppr ns] - -lookupSubBndrOcc :: Bool - -> Name -- Parent - -> SDoc - -> RdrName - -> RnM (Either NotInScopeError Name) --- Find all the things the rdr-name maps to --- and pick the one with the right parent name -lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do - res <- - lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $ - -- This happens for built-in classes, see mod052 for example - lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name - case res of - NameNotFound -> return (Left (UnknownSubordinate doc)) - FoundChild _p child -> return (Right (greNameMangledName child)) - IncorrectParent {} - -- See [Mismatched class methods and associated type families] - -- in TcInstDecls. - -> return $ Left (UnknownSubordinate doc) - -{- -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurrence -of 'G' in the 'instance C S' decl is unambiguous, because C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the enclosing instance decl, if any. - -Note [Looking up Exact RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames are generated by: - -* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs) -* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate) - -For data types and classes have Exact system Names in the binding -positions for constructors, TyCons etc. For example - [d| data T = MkT Int |] -when we splice in and convert to HsSyn RdrName, we'll get - data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... -These System names are generated by GHC.ThToHs.thRdrName - -But, constructors and the like need External Names, not System Names! -So we do the following - - * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a - non-External Name, and make an External name for it. This is - the name that goes in the GlobalRdrEnv - - * When looking up an occurrence of an Exact name, done in - GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the - GlobalRdrEnv, and use the one from the envt -- it will be an - External Name in the case of the data type/constructor above. - - * Exact names are also use for purely local binders generated - by TH, such as \x_33. x_33 - Both binder and occurrence are Exact RdrNames. The occurrence - gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and - misses, because lookupLocalRdrEnv always returns Nothing for - an Exact Name. Now we fall through to lookupExactOcc, which - will find the Name is not in the GlobalRdrEnv, so we just use - the Exact supplied Name. - -Note [Splicing Exact names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the splice $(do { x <- newName "x"; return (VarE x) }) -This will generate a (HsExpr RdrName) term that mentions the -Exact RdrName "x_56" (or whatever), but does not bind it. So -when looking such Exact names we want to check that it's in scope, -otherwise the type checker will get confused. To do this we need to -keep track of all the Names in scope, and the LocalRdrEnv does just that; -we consult it with RdrName.inLocalRdrEnvScope. - -There is another wrinkle. With TH and -XDataKinds, consider - $( [d| data Nat = Zero - data T = MkT (Proxy 'Zero) |] ) -After splicing, but before renaming we get this: - data Nat_77{tc} = Zero_78{d} - data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) -The occurrence of 'Zero in the data type for T has the right unique, -but it has a TcClsName name-space in its OccName. (This is set by -the ctxt_ns argument of Convert.thRdrName.) When we check that is -in scope in the GlobalRdrEnv, we need to look up the DataName namespace -too. (An alternative would be to make the GlobalRdrEnv also have -a Name -> GRE mapping.) - -Note [Template Haskell ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The GlobalRdrEnv invariant says that if - occ -> [gre1, ..., gren] -then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). -This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). - -So how can we get multiple gres in lookupExactOcc_maybe? Because in -TH we might use the same TH NameU in two different name spaces. -eg (#7241): - $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) -Here we generate a type constructor and data constructor with the same -unique, but different name spaces. - -It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would -mean looking up the OccName in every name-space, just in case, and that -seems a bit brutal. So it's just done here on lookup. But we might -need to revisit that choice. - -Note [Usage for sub-bndrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have this - import qualified M( C( f ) ) - instance M.C T where - f x = x -then is the qualified import M.f used? Obviously yes. -But the RdrName used in the instance decl is unqualified. In effect, -we fill in the qualification by looking for f's whose class is M.C -But when adding to the UsedRdrNames we must make that qualification -explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". - -So we make up a suitable (fake) RdrName. But be careful - import qualified M - import M( C(f) ) - instance C T where - f x = x -Here we want to record a use of 'f', not of 'M.f', otherwise -we'll miss the fact that the qualified import is redundant. - --------------------------------------------------- --- Occurrences --------------------------------------------------- --} - - -lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRn = wrapLocMA lookupOccRn - -lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr - -lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField - -lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone - -lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Just look in the local environment -lookupLocalOccRn_maybe rdr_name - = do { local_env <- getLocalRdrEnv - ; return (lookupLocalRdrEnv local_env rdr_name) } - -lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) --- Just look in the local environment -lookupLocalOccThLvl_maybe name - = do { lcl_env <- getLclEnv - ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } - --- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to --- determine what kind of suggestions should be displayed if it is not in scope -lookupOccRn' :: WhatLooking -> RdrName -> RnM Name -lookupOccRn' which_suggest rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> reportUnboundName' which_suggest rdr_name } - --- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if --- it is not in scope -lookupOccRn :: RdrName -> RnM Name -lookupOccRn = lookupOccRn' WL_Anything - --- lookupOccRnConstr looks up an occurrence of a RdrName and displays --- constructors and pattern synonyms as suggestions if it is not in scope -lookupOccRnConstr :: RdrName -> RnM Name -lookupOccRnConstr = lookupOccRn' WL_Constructor - --- lookupOccRnRecField looks up an occurrence of a RdrName and displays --- record fields as suggestions if it is not in scope -lookupOccRnRecField :: RdrName -> RnM Name -lookupOccRnRecField = lookupOccRn' WL_RecField - --- lookupOccRnRecField looks up an occurrence of a RdrName and displays --- no suggestions if it is not in scope -lookupOccRnNone :: RdrName -> RnM Name -lookupOccRnNone = lookupOccRn' WL_None - --- Only used in one place, to rename pattern synonym binders. --- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind -lookupLocalOccRn :: RdrName -> RnM Name -lookupLocalOccRn rdr_name - = do { mb_name <- lookupLocalOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name } - --- lookupTypeOccRn looks up an optionally promoted RdrName. --- Used for looking up type variables. -lookupTypeOccRn :: RdrName -> RnM Name --- see Note [Demotion] -lookupTypeOccRn rdr_name - | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> - if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] - then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope - else lookup_demoted rdr_name } - -{- Note [eqTyCon (~) compatibility fallback] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before GHC Proposal #371, the (~) type operator used in type equality -constraints (a~b) was considered built-in syntax. - -This had two implications: - -1. Users could use it without importing it from Data.Type.Equality or Prelude. -2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead) - -To ease migration and minimize breakage, we continue to support those usages -but emit appropriate warnings. --} - -lookup_demoted :: RdrName -> RnM Name -lookup_demoted rdr_name - | Just demoted_rdr <- demoteRdrName rdr_name - -- Maybe it's the name of a *data* constructor - = do { data_kinds <- xoptM LangExt.DataKinds - ; star_is_type <- xoptM LangExt.StarIsType - ; let is_star_type = if star_is_type then StarIsType else StarIsNotType - star_is_type_hints = noStarIsTypeHints is_star_type rdr_name - ; if data_kinds - then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr - ; case mb_demoted_name of - Nothing -> unboundNameX looking_for rdr_name star_is_type_hints - Just demoted_name -> return demoted_name } - else do { -- We need to check if a data constructor of this name is - -- in scope to give good error messages. However, we do - -- not want to give an additional error if the data - -- constructor happens to be out of scope! See #13947. - mb_demoted_name <- discardErrs $ - lookupOccRn_maybe demoted_rdr - ; let suggestion | isJust mb_demoted_name - , let additional = text "to refer to the data constructor of that name?" - = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] - | otherwise - = star_is_type_hints - ; unboundNameX looking_for rdr_name suggestion } } - - | otherwise - = reportUnboundName' (lf_which looking_for) rdr_name - - where - looking_for = LF WL_Constructor WL_Anywhere - --- If the given RdrName can be promoted to the type level and its promoted variant is in scope, --- lookup_promoted returns the corresponding type-level Name. --- Otherwise, the function returns Nothing. --- See Note [Promotion] below. -lookup_promoted :: RdrName -> RnM (Maybe Name) -lookup_promoted rdr_name - | Just promoted_rdr <- promoteRdrName rdr_name - = lookupOccRn_maybe promoted_rdr - | otherwise - = return Nothing - -badVarInType :: RdrName -> RnM Name -badVarInType rdr_name - = do { addErr (TcRnUnpromotableThing name TermVariablePE) - ; return name } - where - name = mkUnboundNameRdr rdr_name - -{- Note [Promoted variables in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#12686): - x = True - data Bad = Bad 'x - -The parser treats the quote in 'x as saying "use the term -namespace", so we'll get (Bad x{v}), with 'x' in the -VarName namespace. If we don't test for this, the renamer -will happily rename it to the x bound at top level, and then -the typecheck falls over because it doesn't have 'x' in scope -when kind-checking. - -Note [Demotion] -~~~~~~~~~~~~~~~ -When the user writes: - data Nat = Zero | Succ Nat - foo :: f Zero -> Int - -'Zero' in the type signature of 'foo' is parsed as: - HsTyVar ("Zero", TcClsName) - -When the renamer hits this occurrence of 'Zero' it's going to realise -that it's not in scope. But because it is renaming a type, it knows -that 'Zero' might be a promoted data constructor, so it will demote -its namespace to DataName and do a second lookup. - -The final result (after the renamer) will be: - HsTyVar ("Zero", DataName) - -Note [Promotion] -~~~~~~~~~~~~~~~ -When the user mentions a type constructor or a type variable in a -term-level context, then we report that a value identifier was expected -instead of a type-level one. That makes error messages more precise. -Previously, such errors contained only the info that a given value was out of scope (#18740). -We promote the namespace of RdrName and look up after that -(see the functions promotedRdrName and lookup_promoted). - -In particular, we have the following error message - • Illegal term-level use of the type constructor ‘Int’ - imported from ‘Prelude’ (and originally defined in ‘GHC.Types’) - • In the first argument of ‘id’, namely ‘Int’ - In the expression: id Int - In an equation for ‘x’: x = id Int - -when the user writes the following declaration - - x = id Int --} - -lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName - -> RnM (Maybe r) -lookupOccRnX_maybe globalLookup wrapper rdr_name - = runMaybeT . msum . map MaybeT $ - [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name - , globalLookup rdr_name ] - --- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) -lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) -lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id - --- | Look up a 'RdrName' used as a variable in an expression. --- --- This may be a local variable, global variable, or one or more record selector --- functions. It will not return record fields created with the --- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). --- --- If the name is not in scope at the term level, but its promoted equivalent is --- in scope at the type level, the lookup will succeed (so that the type-checker --- can report a more informative error later). See Note [Promotion]. --- -lookupExprOccRn :: RdrName -> RnM (Maybe GreName) -lookupExprOccRn rdr_name - = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name - ; case mb_name of - Nothing -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name - -- See Note [Promotion]. - -- We try looking up the name as a - -- type constructor or type variable, if - -- we failed to look up the name at the term level. - p -> return p } - - where - global_lookup :: RdrName -> RnM (Maybe GreName) - global_lookup rdr_name = - do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name - ; case mb_name of - Just (UnambiguousGre name) -> return (Just name) - Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!" - Nothing -> return Nothing - } - -lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Looks up a RdrName occurrence in the top-level --- environment, including using lookupQualifiedNameGHCi --- for the GHCi case, but first tries to find an Exact or Orig name. --- No filter function; does not report an error on failure --- See Note [Errors in lookup functions] --- Uses addUsedRdrName to record use and deprecations --- --- Used directly only by getLocalNonValBinders (new_assoc). -lookupGlobalOccRn_maybe rdr_name = - lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base WantNormal rdr_name) - -lookupGlobalOccRn :: RdrName -> RnM Name --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. Adds an error message if the RdrName is not in scope. --- You usually want to use "lookupOccRn" which also looks in the local --- environment. --- --- Used by exports_from_avail -lookupGlobalOccRn = lookupGlobalOccRn' WantNormal - -lookupGlobalOccRn' :: FieldsOrSelectors -> RdrName -> RnM Name -lookupGlobalOccRn' fos rdr_name = - lookupExactOrOrig rdr_name id $ do - mn <- lookupGlobalOccRn_base fos rdr_name - case mn of - Just n -> return n - Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) - ; unboundName (LF which_suggest WL_Global) rdr_name } - where which_suggest = case fos of - WantNormal -> WL_Anything - WantBoth -> WL_RecField - WantField -> WL_RecField - --- Looks up a RdrName occurrence in the GlobalRdrEnv and with --- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. --- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like --- 'Data.Map.elems' is typed, even if you didn't import Data.Map -lookupGlobalOccRn_base :: FieldsOrSelectors -> RdrName -> RnM (Maybe Name) -lookupGlobalOccRn_base fos rdr_name = - runMaybeT . msum . map MaybeT $ - [ fmap greMangledName <$> lookupGreRn_maybe fos rdr_name - , fmap greNameMangledName <$> lookupOneQualifiedNameGHCi fos rdr_name ] - -- This test is not expensive, - -- and only happens for failed lookups - -lookupInfoOccRn :: RdrName -> RnM [Name] --- lookupInfoOccRn is intended for use in GHCi's ":info" command --- It finds all the GREs that RdrName could mean, not complaining --- about ambiguity, but rather returning them all --- C.f. #9881 --- lookupInfoOccRn is also used in situations where we check for --- at least one definition of the RdrName, not complaining about --- multiple definitions. (See #17832) -lookupInfoOccRn rdr_name = - lookupExactOrOrig rdr_name (:[]) $ - do { rdr_env <- getGlobalRdrEnv - ; let ns = map greMangledName (lookupGRE_RdrName' rdr_name rdr_env) - ; qual_ns <- map greNameMangledName <$> lookupQualifiedNameGHCi WantBoth rdr_name - ; return (ns ++ (qual_ns `minusList` ns)) } - --- | Like 'lookupOccRn_maybe', but with a more informative result if --- the 'RdrName' happens to be a record selector: --- --- * Nothing -> name not in scope (no error reported) --- * Just (UnambiguousGre x) -> name uniquely refers to x, --- or there is a name clash (reported) --- * Just AmbiguousFields -> name refers to two or more record fields --- (no error reported) --- --- See Note [ Unbound vs Ambiguous Names ]. -lookupGlobalOccRn_overloaded :: DuplicateRecordFields -> FieldsOrSelectors -> RdrName - -> RnM (Maybe AmbiguousResult) -lookupGlobalOccRn_overloaded dup_fields_ok fos rdr_name = - lookupExactOrOrig_maybe rdr_name (fmap (UnambiguousGre . NormalGreName)) $ - do { res <- lookupGreRn_helper fos rdr_name - ; case res of - GreNotFound -> fmap UnambiguousGre <$> lookupOneQualifiedNameGHCi fos rdr_name - OneNameMatch gre -> return $ Just (UnambiguousGre (gre_name gre)) - MultipleNames gres - | all isRecFldGRE gres - , dup_fields_ok == DuplicateRecordFields -> return $ Just AmbiguousFields - | otherwise -> do - addNameClashErrRn rdr_name gres - return (Just (UnambiguousGre (gre_name (NE.head gres)))) } - - --- | Result of looking up an occurrence that might be an ambiguous field. -data AmbiguousResult - = UnambiguousGre GreName - -- ^ Occurrence picked out a single name, which may or may not belong to a - -- field (or might be unbound, if an error has been reported already, per - -- Note [ Unbound vs Ambiguous Names ]). - | AmbiguousFields - -- ^ Occurrence picked out two or more fields, and no non-fields. For now - -- this is allowed by DuplicateRecordFields in certain circumstances, as the - -- type-checker may be able to disambiguate later. - - -{- -Note [NoFieldSelectors] -~~~~~~~~~~~~~~~~~~~~~~~ -The NoFieldSelectors extension allows record fields to be defined without -bringing the corresponding selector functions into scope. However, such fields -may still be used in contexts such as record construction, pattern matching or -update. This requires us to distinguish contexts in which selectors are required -from those in which any field may be used. For example: - - {-# LANGUAGE NoFieldSelectors #-} - module M (T(foo), foo) where -- T(foo) refers to the field, - -- unadorned foo to the value binding - data T = MkT { foo :: Int } - foo = () - - bar = foo -- refers to the value binding, field ignored - - module N where - import M (T(..)) - baz = MkT { foo = 3 } -- refers to the field - oops = foo -- an error: the field is in scope but the value binding is not - -Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the -FieldSelectors extension was enabled in the defining module. This allows them -to be filtered out by 'filterFieldGREs'. - -Even when NoFieldSelectors is in use, we still generate selector functions -internally. For example, the expression - getField @"foo" t -or (with dot-notation) - t.foo -extracts the `foo` field of t::T, and hence needs the selector function -(see Note [HasField instances] in GHC.Tc.Instance.Class). In order to avoid -name clashes with normal bindings reusing the names, selector names for such -fields are mangled just as for DuplicateRecordFields (see Note [FieldLabel] in -GHC.Types.FieldLabel). - - -In many of the name lookup functions in this module we pass a FieldsOrSelectors -value, indicating what we are looking for: - - * WantNormal: fields are in scope only if they have an accompanying selector - function, e.g. we are looking up a variable in an expression - (lookupExprOccRn). - - * WantBoth: any name or field will do, regardless of whether the selector - function is available, e.g. record updates (lookupRecFieldOcc_update) with - NoDisambiguateRecordFields. - - * WantField: any field will do, regardless of whether the selector function is - available, but ignoring any non-field names, e.g. record updates - (lookupRecFieldOcc_update) with DisambiguateRecordFields. - ------------------------------------------------------------------------------------ - Context FieldsOrSelectors ------------------------------------------------------------------------------------ - Record construction/pattern match WantBoth if NoDisambiguateRecordFields - e.g. MkT { foo = 3 } (DisambiguateRecordFields is separate) - - Record update WantBoth if NoDisambiguateRecordFields - e.g. e { foo = 3 } WantField if DisambiguateRecordFields - - :info in GHCi WantBoth - - Variable occurrence in expression WantNormal - Type variable, data constructor - Pretty much everything else ------------------------------------------------------------------------------------ --} - --- | When looking up GREs, we may or may not want to include fields that were --- defined in modules with @NoFieldSelectors@ enabled. See Note --- [NoFieldSelectors]. -data FieldsOrSelectors - = WantNormal -- ^ Include normal names, and fields with selectors, but - -- ignore fields without selectors. - | WantBoth -- ^ Include normal names and all fields (regardless of whether - -- they have selectors). - | WantField -- ^ Include only fields, with or without selectors, ignoring - -- any non-fields in scope. - deriving Eq - -filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] -filterFieldGREs fos = filter (allowGreName fos . gre_name) - -allowGreName :: FieldsOrSelectors -> GreName -> Bool -allowGreName WantBoth _ = True -allowGreName WantNormal (FieldGreName fl) = flHasFieldSelector fl == FieldSelectors -allowGreName WantNormal (NormalGreName _) = True -allowGreName WantField (FieldGreName _) = True -allowGreName WantField (NormalGreName _) = False - - --------------------------------------------------- --- Lookup in the Global RdrEnv of the module --------------------------------------------------- - -data GreLookupResult = GreNotFound - | OneNameMatch GlobalRdrElt - | MultipleNames (NE.NonEmpty GlobalRdrElt) - -lookupGreRn_maybe :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) --- Look up the RdrName in the GlobalRdrEnv --- Exactly one binding: records it as "used", return (Just gre) --- No bindings: return Nothing --- Many bindings: report "ambiguous", return an arbitrary (Just gre) --- Uses addUsedRdrName to record use and deprecations -lookupGreRn_maybe fos rdr_name - = do - res <- lookupGreRn_helper fos rdr_name - case res of - OneNameMatch gre -> return $ Just gre - MultipleNames gres -> do - traceRn "lookupGreRn_maybe:NameClash" (ppr gres) - addNameClashErrRn rdr_name gres - return $ Just (NE.head gres) - GreNotFound -> return Nothing - -{- - -Note [ Unbound vs Ambiguous Names ] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -lookupGreRn_maybe deals with failures in two different ways. If a name -is unbound then we return a `Nothing` but if the name is ambiguous -then we raise an error and return a dummy name. - -The reason for this is that when we call `lookupGreRn_maybe` we are -speculatively looking for whatever we are looking up. If we don't find it, -then we might have been looking for the wrong thing and can keep trying. -On the other hand, if we find a clash then there is no way to recover as -we found the thing we were looking for but can no longer resolve which -the correct one is. - -One example of this is in `lookupTypeOccRn` which first looks in the type -constructor namespace before looking in the data constructor namespace to -deal with `DataKinds`. - -There is however, as always, one exception to this scheme. If we find -an ambiguous occurrence of a record selector and DuplicateRecordFields -is enabled then we defer the selection until the typechecker. - --} - - - - --- Internal Function -lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult -lookupGreRn_helper fos rdr_name - = do { env <- getGlobalRdrEnv - ; case filterFieldGREs fos (lookupGRE_RdrName' rdr_name env) of - [] -> return GreNotFound - [gre] -> do { addUsedGRE True gre - ; return (OneNameMatch gre) } - -- Don't record usage for ambiguous names - -- until we know which is meant - (gre:gres) -> return (MultipleNames (gre NE.:| gres)) } - -lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) --- Used in export lists --- If not found or ambiguous, add error message, and fake with UnboundName --- Uses addUsedRdrName to record use and deprecations -lookupGreAvailRn rdr_name - = do - mb_gre <- lookupGreRn_helper WantNormal rdr_name - case mb_gre of - GreNotFound -> - do - traceRn "lookupGreAvailRn" (ppr rdr_name) - name <- unboundName (LF WL_Anything WL_Global) rdr_name - return (name, avail name) - MultipleNames gres -> - do - addNameClashErrRn rdr_name gres - let unbound_name = mkUnboundNameRdr rdr_name - return (unbound_name, avail unbound_name) - -- Returning an unbound name here prevents an error - -- cascade - OneNameMatch gre -> - return (greMangledName gre, availFromGRE gre) - - -{- -********************************************************* -* * - Deprecations -* * -********************************************************* - -Note [Handling of deprecations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We report deprecations at each *occurrence* of the deprecated thing - (see #5867) - -* We do not report deprecations for locally-defined names. For a - start, we may be exporting a deprecated thing. Also we may use a - deprecated thing in the defn of another deprecated things. We may - even use a deprecated thing in the defn of a non-deprecated thing, - when changing a module's interface. - -* addUsedGREs: we do not report deprecations for sub-binders: - - the ".." completion for records - - the ".." in an export item 'T(..)' - - the things exported by a module export 'module M' --} - -addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () --- Remember use of in-scope data constructors (#7969) -addUsedDataCons rdr_env tycon - = addUsedGREs [ gre - | dc <- tyConDataCons tycon - , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] - -addUsedGRE :: Bool -> GlobalRdrElt -> RnM () --- Called for both local and imported things --- Add usage *and* warn if deprecated -addUsedGRE warn_if_deprec gre - = do { when warn_if_deprec (warnIfDeprecated gre) - ; unless (isLocalGRE gre) $ - do { env <- getGblEnv - ; traceRn "addUsedGRE" (ppr gre) - ; updMutVar (tcg_used_gres env) (gre :) } } - -addUsedGREs :: [GlobalRdrElt] -> RnM () --- Record uses of any *imported* GREs --- Used for recording used sub-bndrs --- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] -addUsedGREs gres - | null imp_gres = return () - | otherwise = do { env <- getGblEnv - ; traceRn "addUsedGREs" (ppr imp_gres) - ; updMutVar (tcg_used_gres env) (imp_gres ++) } - where - imp_gres = filterOut isLocalGRE gres - -warnIfDeprecated :: GlobalRdrElt -> RnM () -warnIfDeprecated gre@(GRE { gre_imp = iss }) - | Just imp_spec <- headMaybe iss - = do { dflags <- getDynFlags - ; this_mod <- getModule - ; when (wopt Opt_WarnWarningsDeprecations dflags && - not (nameIsLocalOrFrom this_mod name)) $ - -- See Note [Handling of deprecations] - do { iface <- loadInterfaceForName doc name - ; case lookupImpDeprec iface gre of - Just deprText -> addDiagnostic $ - TcRnPragmaWarning { - pragma_warning_occ = occ, - pragma_warning_msg = deprText, - pragma_warning_import_mod = importSpecModule imp_spec, - pragma_warning_defined_mod = definedMod - } - Nothing -> return () } } - | otherwise - = return () - where - occ = greOccName gre - name = greMangledName gre - definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) - doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" - -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) -lookupImpDeprec iface gre - = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, - case gre_par gre of -- or its parent, is warn'd - ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - NoParent -> Nothing - -{- -Note [Used names with interface not loaded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's (just) possible to find a used -Name whose interface hasn't been loaded: - -a) It might be a WiredInName; in that case we may not load - its interface (although we could). - -b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses - if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type - is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). - In that obscure case it won't force the interface in. - -In both cases we simply don't permit deprecations; -this is, after all, wired-in stuff. - - -********************************************************* -* * - GHCi support -* * -********************************************************* - -A qualified name on the command line can refer to any module at -all: we try to load the interface if we don't already have it, just -as if there was an "import qualified M" declaration for every -module. - -For example, writing `Data.List.sort` will load the interface file for -`Data.List` as if the user had written `import qualified Data.List`. - -If we fail we just return Nothing, rather than bleating -about "attempting to use module ‘D’ (./D.hs) which is not loaded" -which is what loadSrcInterface does. - -It is enabled by default and disabled by the flag -`-fno-implicit-import-qualified`. - -Note [Safe Haskell and GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We DON'T do this Safe Haskell as we need to check imports. We can -and should instead check the qualified import but at the moment -this requires some refactoring so leave as a TODO - -Note [DuplicateRecordFields and -fimplicit-import-qualified] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When DuplicateRecordFields is used, a single module can export the same OccName -multiple times, for example: - - module M where - data S = MkS { foo :: Int } - data T = MkT { foo :: Int } - -Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an -ambiguity error. - --} - - --- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an --- ambiguity error if there are more than one. -lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GreName) -lookupOneQualifiedNameGHCi fos rdr_name = do - gnames <- lookupQualifiedNameGHCi fos rdr_name - case gnames of - [] -> return Nothing - [gname] -> return (Just gname) - (gname:gnames') -> do addNameClashErrRn rdr_name (toGRE gname NE.:| map toGRE gnames') - return (Just (NormalGreName (mkUnboundNameRdr rdr_name))) - where - -- Fake a GRE so we can report a sensible name clash error if - -- -fimplicit-import-qualified is used with a module that exports the same - -- field name multiple times (see - -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). - toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is } - is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } - , is_item = ImpAll } - -- If -fimplicit-import-qualified succeeded, the name must be qualified. - (mod, _) = fromMaybe (pprPanic "lookupOneQualifiedNameGHCi" (ppr rdr_name)) (isQual_maybe rdr_name) - - --- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using --- @-fimplicit-import-qualified@). This will normally be zero or one, but may --- be more in the presence of @DuplicateRecordFields@. -lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [GreName] -lookupQualifiedNameGHCi fos rdr_name - = -- We want to behave as we would for a source file import here, - -- and respect hiddenness of modules/packages, hence loadSrcInterface. - do { dflags <- getDynFlags - ; is_ghci <- getIsGHCi - ; go_for_it dflags is_ghci } - - where - go_for_it dflags is_ghci - | Just (mod,occ) <- isQual_maybe rdr_name - , is_ghci - , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour - , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] - = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual - ; case res of - Succeeded iface - -> return [ gname - | avail <- mi_exports iface - , gname <- availGreNames avail - , occName gname == occ - -- Include a field if it has a selector or we are looking for all fields; - -- see Note [NoFieldSelectors]. - , allowGreName fos gname - ] - - _ -> -- Either we couldn't load the interface, or - -- we could but we didn't find the name in it - do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) - ; return [] } } - - | otherwise - = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) - ; return [] } - - doc = text "Need to find" <+> ppr rdr_name - -{- -Note [Looking up signature names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -lookupSigOccRn is used for type signatures and pragmas -Is this valid? - module A - import M( f ) - f :: Int -> Int - f x = x -It's clear that the 'f' in the signature must refer to A.f -The Haskell98 report does not stipulate this, but it will! -So we must treat the 'f' in the signature in the same way -as the binding occurrence of 'f', using lookupBndrRn - -However, consider this case: - import M( f ) - f :: Int -> Int - g x = x -We don't want to say 'f' is out of scope; instead, we want to -return the imported 'f', so that later on the renamer will -correctly report "misplaced type sig". - -Note [Signatures for top level things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data HsSigCtxt = ... | TopSigCtxt NameSet | .... - -* The NameSet says what is bound in this group of bindings. - We can't use isLocalGRE from the GlobalRdrEnv, because of this: - f x = x - $( ...some TH splice... ) - f :: Int -> Int - When we encounter the signature for 'f', the binding for 'f' - will be in the GlobalRdrEnv, and will be a LocalDef. Yet the - signature is mis-placed - -* For type signatures the NameSet should be the names bound by the - value bindings; for fixity declarations, the NameSet should also - include class sigs and record selectors - - infix 3 `f` -- Yes, ok - f :: C a => a -> a -- No, not ok - class C a where - f :: a -> a --} - -data HsSigCtxt - = TopSigCtxt NameSet -- At top level, binding these names - -- See Note [Signatures for top level things] - | LocalBindCtxt NameSet -- In a local binding, binding these names - | ClsDeclCtxt Name -- Class decl for this class - | InstDeclCtxt NameSet -- Instance decl whose user-written method - -- bindings are for these methods - | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names - | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types - -- in the group - -instance Outputable HsSigCtxt where - ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns - ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns - ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n - ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns - ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns - ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns - -lookupSigOccRn :: HsSigCtxt - -> Sig GhcPs - -> LocatedA RdrName -> RnM (LocatedA Name) -lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) - -lookupSigOccRnN :: HsSigCtxt - -> Sig GhcPs - -> LocatedN RdrName -> RnM (LocatedN Name) -lookupSigOccRnN ctxt sig = lookupSigCtxtOccRnN ctxt (hsSigDoc sig) - - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRnN :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> LocatedN RdrName -> RnM (LocatedN Name) -lookupSigCtxtOccRnN ctxt what - = wrapLocMA $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr_name err) - ; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRn :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> LocatedA RdrName -> RnM (LocatedA Name) -lookupSigCtxtOccRn ctxt what - = wrapLocMA $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr_name err) - ; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } - -lookupBindGroupOcc :: HsSigCtxt - -> SDoc - -> RdrName -> RnM (Either NotInScopeError Name) --- Looks up the RdrName, expecting it to resolve to one of the --- bound names passed in. If not, return an appropriate error message --- --- See Note [Looking up signature names] -lookupBindGroupOcc ctxt what rdr_name - | Just n <- isExact_maybe rdr_name - = lookupExactOcc_either n -- allow for the possibility of missing Exacts; - -- see Note [dataTcOccs and Exact Names] - -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n' <- lookupOrig rdr_mod rdr_occ - ; return (Right n') } - - | otherwise - = case ctxt of - HsBootCtxt ns -> lookup_top (`elemNameSet` ns) - TopSigCtxt ns -> lookup_top (`elemNameSet` ns) - RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) - LocalBindCtxt ns -> lookup_group ns - ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 - then return (Right $ mkUnboundNameRdr rdr_name) - else lookup_top (`elemNameSet` ns) - where - lookup_cls_op cls - = lookupSubBndrOcc True cls doc rdr_name - where - doc = text "method of class" <+> quotes (ppr cls) - - lookup_top keep_me - = do { env <- getGlobalRdrEnv - ; dflags <- getDynFlags - ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - names_in_scope = -- If rdr_name lacks a binding, only - -- recommend alternatives from related - -- namespaces. See #17593. - filter (\n -> nameSpacesRelated dflags WL_Anything - (rdrNameSpace rdr_name) - (nameNameSpace n)) - $ map greMangledName - $ filter isLocalGRE - $ globalRdrEnvElts env - candidates_msg = candidates names_in_scope - ; case filter (keep_me . greMangledName) all_gres of - [] | null all_gres -> bale_out_with candidates_msg - | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (greMangledName gre)) } - - lookup_group bound_names -- Look in the local envt (not top level) - = do { mname <- lookupLocalOccRn_maybe rdr_name - ; env <- getLocalRdrEnv - ; let candidates_msg = candidates $ localRdrEnvElts env - ; case mname of - Just n - | n `elemNameSet` bound_names -> return (Right n) - | otherwise -> bale_out_with local_msg - Nothing -> bale_out_with candidates_msg } - - bale_out_with hints = return (Left $ MissingBinding what hints) - - local_msg = [SuggestMoveToDeclarationSite what rdr_name] - - -- Identify all similar names and produce a message listing them - candidates :: [Name] -> [GhcHint] - candidates names_in_scope - | (nm : nms) <- map SimilarName similar_names - = [SuggestSimilarNames rdr_name (nm NE.:| nms)] - | otherwise - = [] - where - similar_names - = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) - $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) - names_in_scope - - ---------------- -lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] --- GHC extension: look up both the tycon and data con or variable. --- Used for top-level fixity signatures and deprecations. --- Complain if neither is in scope. --- See Note [Fixity signature lookup] -lookupLocalTcNames ctxt what rdr_name - = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) - ; let (errs, names) = partitionEithers mb_gres - ; when (null names) $ - addErr (head errs) -- Bleat about one only - ; return names } - where - lookup rdr = do { this_mod <- getModule - ; nameEither <- lookupBindGroupOcc ctxt what rdr - ; return (guard_builtin_syntax this_mod rdr nameEither) } - - -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 - guard_builtin_syntax this_mod rdr (Right name) - | Just _ <- isBuiltInOcc_maybe (occName rdr) - , this_mod /= nameModule name - = Left $ TcRnIllegalBuiltinSyntax what rdr - | otherwise - = Right (rdr, name) - guard_builtin_syntax _ _ (Left err) - = Left $ mkTcRnNotInScope rdr_name err - -dataTcOccs :: RdrName -> [RdrName] --- Return both the given name and the same name promoted to the TcClsName --- namespace. This is useful when we aren't sure which we are looking at. --- See also Note [dataTcOccs and Exact Names] -dataTcOccs rdr_name - | isDataOcc occ || isVarOcc occ - = [rdr_name, rdr_name_tc] - | otherwise - = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - -{- -Note [dataTcOccs and Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact. However, the TH `Name` type isn't expressive -enough to always track the correct namespace information, so we sometimes get -the right Unique but wrong namespace. Thus, we still have to do the double-lookup -for Exact RdrNames. - -There is also an awkward situation for built-in syntax. Example in GHCi - :info [] -This parses as the Exact RdrName for nilDataCon, but we also want -the list type constructor. - -Note that setRdrNameSpace on an Exact name requires the Name to be External, -which it always is for built in syntax. --} - - - -{- -************************************************************************ -* * - Rebindable names - Dealing with rebindable syntax is driven by the - Opt_RebindableSyntax dynamic flag. - - In "deriving" code we don't want to use rebindable syntax - so we switch off the flag locally - -* * -************************************************************************ - -Haskell 98 says that when you say "3" you get the "fromInteger" from the -Standard Prelude, regardless of what is in scope. However, to experiment -with having a language that is less coupled to the standard prelude, we're -trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" -happens to be in scope. Then you can - import Prelude () - import MyPrelude as Prelude -to get the desired effect. - -At the moment this just happens for - * fromInteger, fromRational on literals (in expressions and patterns) - * negate (in expressions) - * minus (arising from n+k patterns) - * "do" notation - -We store the relevant Name in the HsSyn tree, in - * HsIntegral/HsFractional/HsIsString - * NegApp - * NPlusKPat - * HsDo -respectively. Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName, -fromRationalName etc), but the renamer changes this to the appropriate user -name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. - -We treat the original (standard) names as free-vars too, because the type checker -checks the type of the user thing against the type of the standard thing. --} - -lookupIfThenElse :: RnM (Maybe Name) --- Looks up "ifThenElse" if rebindable syntax is on -lookupIfThenElse - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on - then return Nothing - else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse")) - ; return (Just ite) } } - -lookupSyntaxName :: Name -- ^ The standard name - -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name --- Lookup a Name that may be subject to Rebindable Syntax (RS). --- --- - When RS is off, just return the supplied (standard) Name --- --- - When RS is on, look up the OccName of the supplied Name; return --- what we find, or the supplied Name if there is nothing in scope -lookupSyntaxName std_name - = do { rebind <- xoptM LangExt.RebindableSyntax - ; if not rebind - then return (std_name, emptyFVs) - else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name)) - ; return (nm, unitFV nm) } } - -lookupSyntaxExpr :: Name -- ^ The standard name - -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name -lookupSyntaxExpr std_name - = do { (name, fvs) <- lookupSyntaxName std_name - ; return (nl_HsVar name, fvs) } - -lookupSyntax :: Name -- The standard name - -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard - -- name -lookupSyntax std_name - = do { (expr, fvs) <- lookupSyntaxExpr std_name - ; return (mkSyntaxExpr expr, fvs) } - -lookupSyntaxNames :: [Name] -- Standard names - -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames - -- this works with CmdTop, which wants HsExprs, not SyntaxExprs -lookupSyntaxNames std_names - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (map (HsVar noExtField . noLocA) std_names, emptyFVs) - else - do { usr_names <- - mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } } - - -{- -Note [QualifiedDo] -~~~~~~~~~~~~~~~~~~ -QualifiedDo is implemented using the same placeholders for operation names in -the AST that were devised for RebindableSyntax. Whenever the renamer checks -which names to use for do syntax, it first checks if the do block is qualified -(e.g. M.do { stmts }), in which case it searches for qualified names. If the -qualified names are not in scope, an error is produced. If the do block is not -qualified, the renamer does the usual search of the names which considers -whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven -by the Opt_QualifiedDo dynamic flag. --} - --- Lookup operations for a qualified do. If the context is not a qualified --- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. -lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars) -lookupQualifiedDoExpr ctxt std_name - = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name - --- Like lookupQualifiedDoExpr but for producing SyntaxExpr. --- See Note [QualifiedDo]. -lookupQualifiedDo - :: HsStmtContext p - -> Name - -> RnM (SyntaxExpr GhcRn, FreeVars) -lookupQualifiedDo ctxt std_name - = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name - -lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) -lookupNameWithQualifier std_name modName - = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name)) - ; return (qname, unitFV qname) } - --- See Note [QualifiedDo]. -lookupQualifiedDoName - :: HsStmtContext p - -> Name - -> RnM (Name, FreeVars) -lookupQualifiedDoName ctxt std_name - = case qualifiedDoModuleName_maybe ctxt of - Nothing -> lookupSyntaxName std_name - Just modName -> lookupNameWithQualifier std_name modName - - --- Error messages - -badOrigBinding :: RdrName -> TcRnMessage -badOrigBinding name - | Just _ <- isBuiltInOcc_maybe occ = TcRnIllegalBindingOfBuiltIn occ - | otherwise = TcRnNameByTemplateHaskellQuote name - where - occ = rdrNameOcc $ filterCTuple name +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 + +GHC.Rename.Env contains functions which convert RdrNames into Names. + +-} + +module GHC.Rename.Env ( + newTopSrcBinder, + + lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn, + lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, + + lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, + lookupLocatedOccRnNone, + lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe, + lookupLocalOccRn_maybe, lookupInfoOccRn, + lookupLocalOccThLvl_maybe, lookupLocalOccRn, + lookupTypeOccRn, + lookupGlobalOccRn, lookupGlobalOccRn_maybe, + + lookupExprOccRn, + lookupRecFieldOcc, + lookupRecUpdFields, + getFieldUpdLbl, + getUpdFieldLbls, + + ChildLookupResult(..), + lookupSubBndrOcc_helper, + + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN, + lookupSigCtxtOccRn, + + lookupInstDeclBndr, lookupFamInstName, + lookupConstructorInfo, lookupConstructorFields, + lookupGREInfo, + + lookupGreAvailRn, + + -- Rebindable Syntax + lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames, + lookupSyntaxName, + lookupIfThenElse, + + -- QualifiedDo + lookupQualifiedDoExpr, lookupQualifiedDo, + lookupQualifiedDoName, lookupNameWithQualifier, + + -- Constructing usage information + DeprecationWarnings(..), + addUsedGRE, addUsedGREs, addUsedDataCons, + + dataTcOccs, --TODO: Move this somewhere, into utils? + + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import GHC.Iface.Load +import GHC.Iface.Env +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr (pprScopeError) +import GHC.Tc.Utils.Env +import GHC.Tc.Types.LclEnv +import GHC.Tc.Utils.Monad +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Hint +import GHC.Types.Error +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Warnings ( WarningTxt(..) ) +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Builtin.Names( rOOT_MAIN ) +import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..), tupleSortBoxity ) +import GHC.Types.TyThing ( tyThingGREInfo ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain (assert) +import GHC.Data.Maybe +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Data.List.SetOps ( minusList ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Unbound +import GHC.Rename.Utils +import GHC.Data.Bag +import GHC.Types.PkgQual +import GHC.Types.GREInfo + +import Control.Arrow ( first ) +import Control.Monad +import Data.Either ( partitionEithers ) +import Data.Function ( on ) +import Data.List ( find, partition, groupBy, sortBy ) +import Data.Foldable ( for_ ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi +import System.IO.Unsafe ( unsafePerformIO ) + +{- +********************************************************* +* * + Source-code binders +* * +********************************************************* + +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +warning until you use the identifier further downstream. This would +require adjusting addUsedGRE so that during signature compilation, +we do not report deprecation warnings for LocalDef. See also +Note [Handling of deprecations] +-} + +newTopSrcBinder :: LocatedN RdrName -> RnM Name +newTopSrcBinder (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + do { this_mod <- getModule + ; externaliseName this_mod name } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { this_mod <- getModule + ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name)) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the TcRnBindingOfExistingName error message. + -- + + -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore + -- because External Core has been removed but we instead have some similar logic for + -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id. + + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + ; newGlobalBinder rdr_mod rdr_occ (locA loc) } + + | otherwise + = do { when (isQual rdr_name) + (addErrAt (locA loc) (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we get a confusing "M.T is not in scope" error later + + ; stage <- getStage + ; if isBrackStage stage then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } + else + do { this_mod <- getModule + ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc)) + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) } + } + +{- +********************************************************* +* * + Source code occurrences +* * +********************************************************* + +Looking up a name in the GHC.Rename.Env. + +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (#3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. +-} + +-- Can be made to not be exposed +-- Only used unwrapped in rnAnnProvenance +lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. +-- +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. +lookupTopBndrRn which_suggest rdr_name = + lookupExactOrOrig rdr_name greName $ + do { -- Check for operators in type or class declarations + -- See Note [Type and class operator definitions] + let occ = rdrNameOcc rdr_name + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- xoptM LangExt.TypeOperators + ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) + ; env <- getGlobalRdrEnv + ; case filter isLocalGRE (lookupGRE env $ LookupRdrName rdr_name $ RelevantGREsFOS WantNormal) of + [gre] -> return (greName gre) + _ -> do -- Ambiguous (can't happen) or unbound + traceRn "lookupTopBndrRN fail" (ppr rdr_name) + unboundName (LF which_suggest WL_LocalTop) rdr_name + } + +lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor) + +lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name) +lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor) + +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything) + +lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name) +lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything) + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one, see +-- Note [Errors in lookup functions] +lookupExactOcc_either :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupExactOcc_either name + | Just thing <- wiredInNameTyThing_maybe name + , Just tycon <- case thing of + ATyCon tc -> Just tc + AConLike (RealDataCon dc) -> Just (dataConTyCon dc) + _ -> Nothing + , Just tupleSort <- tyConTuple_maybe tycon + = do { let tupArity = case tupleSort of + -- Unboxed tuples have twice as many arguments because of the + -- 'RuntimeRep's (#17837) + UnboxedTuple -> tyConArity tycon `div` 2 + _ -> tyConArity tycon + ; let info = case thing of + ATyCon {} -> IAmTyCon $ TupleFlavour $ tupleSortBoxity tupleSort + _ -> IAmConLike $ mkConInfo tupArity [] + ; checkTupSize tupArity + ; return $ Right $ mkExactGRE name info } + + | isExternalName name + = do { info <- lookupExternalExactName name + ; return $ Right $ mkExactGRE name info } + + | otherwise + = lookupLocalExactGRE name + +lookupExternalExactName :: Name -> RnM GREInfo +lookupExternalExactName name + = do { thing <- + case wiredInNameTyThing_maybe name of + Just thing -> return thing + _ -> tcLookupGlobal name + ; return $ tyThingGREInfo thing } + +lookupLocalExactGRE :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupLocalExactGRE name + = do { env <- getGlobalRdrEnv + ; let lk = LookupExactName { lookupExactName = name + , lookInAllNameSpaces = True } + -- We want to check for clashes where the same Unique + -- occurs in two different NameSpaces, as per + -- Note [Template Haskell ambiguity]. So we + -- check ALL namespaces, not just the NameSpace of the Name. + -- See test cases T9066, T11809. + ; case lookupGRE env lk of + [gre] -> return (Right gre) + + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; let gre = mkLocalVanillaGRE NoParent name -- LocalRdrEnv only contains Vanilla things + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right gre) + else + do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; th_topnames <- readTcRef th_topnames_var + ; if name `elemNameSet` th_topnames + then return (Right gre) + else return (Left (NoExactName name)) + } + } + + gres -> return (Left (SameName gres)) } + -- Ugh! See Note [Template Haskell ambiguity] } + +----------------------------------------------- +lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what rdr + = do { when (isQual rdr) + (addErr (badQualBndrErr rdr)) + -- In an instance decl you aren't allowed + -- to use a qualified name for the method + -- (Although it'd make perfect sense.) + ; mb_name <- lookupSubBndrOcc + NoDeprecationWarnings + -- we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + cls doc rdr + ; case mb_name of + Left err -> do { addErr (mkTcRnNotInScope rdr err) + ; return (mkUnboundNameRdr rdr) } + Right nm -> return nm } + where + doc = what <+> text "of class" <+> quotes (ppr cls) + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> LocatedN RdrName + -> RnM (LocatedN Name) +-- Used for TyData and TySynonym family instances only, +-- See Note [Family instance binders] +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind + = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRnConstr tc_rdr + +----------------------------------------------- +lookupConstructorFields :: HasDebugCallStack => Name -> RnM [FieldLabel] +lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo + +-- | Look up the arity and record fields of a constructor. +lookupConstructorInfo :: HasDebugCallStack => Name -> RnM ConInfo +lookupConstructorInfo con_name + = do { info <- lookupGREInfo_GRE con_name + ; case info of + IAmConLike con_info -> return con_info + UnboundGRE -> return ConHasPositionalArgs + _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ + vcat [ text "name:" <+> ppr con_name ] + } + +-- In CPS style as `RnM r` is monadic +-- Reports an error if the name is an Exact or Orig and it can't find the name +-- Otherwise if it is not an Exact or Orig, returns k +lookupExactOrOrig :: RdrName -> (GlobalRdrElt -> r) -> RnM r -> RnM r +lookupExactOrOrig rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig gre -> return $ res gre + NotExactOrOrig -> k + ExactOrOrigError e -> + do { addErr (mkTcRnNotInScope rdr_name e) + ; return $ res (mkUnboundGRERdr rdr_name) } } + +-- Variant of 'lookupExactOrOrig' that does not report an error +-- See Note [Errors in lookup functions] +-- Calls k if the name is neither an Exact nor Orig +lookupExactOrOrig_maybe :: RdrName -> (Maybe GlobalRdrElt -> r) -> RnM r -> RnM r +lookupExactOrOrig_maybe rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig gre -> return (res (Just gre)) + ExactOrOrigError _ -> return (res Nothing) + NotExactOrOrig -> k } + +data ExactOrOrigResult + = FoundExactOrOrig GlobalRdrElt + -- ^ Found an Exact Or Orig Name + | ExactOrOrigError NotInScopeError + -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name + | NotExactOrOrig + -- ^ The RdrName is neither an Exact nor Orig + +-- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' +lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult +lookupExactOrOrig_base rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = cvtEither <$> lookupExactOcc_either n + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { nm <- lookupOrig rdr_mod rdr_occ + + ; this_mod <- getModule + ; mb_gre <- + if nameIsLocalOrFrom this_mod nm + then lookupLocalExactGRE nm + else do { info <- lookupExternalExactName nm + ; return $ Right $ mkExactGRE nm info } + ; return $ case mb_gre of + Left err -> ExactOrOrigError err + Right gre -> FoundExactOrOrig gre } + | otherwise = return NotExactOrOrig + where + cvtEither (Left e) = ExactOrOrigError e + cvtEither (Right gre) = FoundExactOrOrig gre + +{- Note [Errors in lookup functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many of these lookup functions will attach an error if it can't find the Name it +is trying to lookup. However there are also _maybe and _either variants for many +of these functions. + +These variants should *not* attach any errors, as there are +places where we want to attempt looking up a name, but it's not the end of the +world if we don't find it. + +For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple +times for varying names in different namespaces. lookupOccRn_maybe should +therefore never attach an error, instead just return a Nothing. + +For these _maybe/_either variant functions then, avoid calling further lookup +functions that can attach errors and instead call their _maybe/_either +counterparts. +-} + +----------------------------------------------- +-- | Look up an occurrence of a field in record construction or pattern +-- matching (but not update). +-- +-- If -XDisambiguateRecordFields is off, then we will pass 'Nothing' for the +-- 'DataCon' 'Name', i.e. we don't use the data constructor for disambiguation. +-- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. +lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual + -- Just con => use data con to disambiguate + -> RdrName + -> RnM Name +lookupRecFieldOcc mb_con rdr_name + | Just con <- mb_con + , isUnboundName con -- Avoid error cascade + = return $ mk_unbound_rec_fld con + | Just con <- mb_con + = do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) + ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell] + do { flds <- lookupConstructorFields con + ; env <- getGlobalRdrEnv + ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds + -- We have the label, now check it is in scope. If + -- there is a qualifier, use pickGREs to check that + -- the qualifier is correct, and return the filtered + -- GRE so we get import usage right (see #17853). + gre <- lookupGRE_FieldLabel env fl + if isQual rdr_name + then listToMaybe $ pickGREs rdr_name [gre] + else return gre + ; traceRn "lookupRecFieldOcc" $ + vcat [ text "mb_con:" <+> ppr mb_con + , text "rdr_name:" <+> ppr rdr_name + , text "flds:" <+> ppr flds + , text "mb_gre:" <+> ppr mb_gre ] + ; mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre + ; return $ flSelector . fieldGRELabel <$> mb_gre } + ; case mb_nm of + { Nothing -> do { addErr (badFieldConErr con lbl) + ; return $ mk_unbound_rec_fld con } + ; Just nm -> return nm } } + + | otherwise -- Can't use the data constructor to disambiguate + = lookupGlobalOccRn' (RelevantGREsFOS WantField) rdr_name + -- This use of Global is right as we are looking up a selector, + -- which can only be defined at the top level. + + where + -- When lookup fails, make an unbound name with the right record field + -- namespace, as that's what we expect to be returned + -- from 'lookupRecFieldOcc'. See T14307. + mk_unbound_rec_fld con = mkUnboundName $ + mkRecFieldOccFS (getOccFS con) (occNameFS occ) + occ = rdrNameOcc rdr_name + + ensure_recfld :: GlobalRdrElt -> Maybe Name + ensure_recfld gre = do { guard (isRecFldGRE gre) + ; return $ greName gre } + +{- Note [DisambiguateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record construction or pattern +matching, we can take advantage of the data constructor name to +resolve fields that would otherwise be ambiguous (provided the +-XDisambiguateRecordFields flag is on). + +For example, consider: + + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + e = MkS { x = 3 } + +When we are renaming the occurrence of `x` in `e`, instead of looking +`x` up directly (and finding both fields), lookupRecFieldOcc will +search the fields of `MkS` to find the only possible `x` the user can +mean. + +Of course, we still have to check the field is in scope, using +lookupGRE_FieldLabel. The handling of qualified imports is slightly +subtle: the occurrence may be unqualified even if the field is +imported only qualified (but if the occurrence is qualified, the +qualifier must be correct). For example: + + module A where + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + module B where + import qualified A (S(..)) + import A (T(MkT)) + + e1 = MkT { x = 3 } -- x not in scope, so fail + e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail + e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) + +In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, +lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard +will fail because the field RdrName `B.x` is qualified and pickGREs +rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the +GRE for `A.x` and the guard will succeed because the field RdrName `x` +is unqualified. + + +Note [DisambiguateRecordFields for updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record update, we can take advantage of +the fact that we know we are looking for a field, even though we do not know the +data constructor name (as in Note [DisambiguateRecordFields]), provided the +-XDisambiguateRecordFields flag is on. + +For example, consider: + + module N where + f = () + + {-# LANGUAGE DisambiguateRecordFields #-} + module M where + import N (f) + data T = MkT { f :: Int } + t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean + u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' + +We filter out non-fields in lookupFieldGREs by using isRecFldGRE, which allows +us to accept the above program. +Of course, if a record update has two fields in scope with the same name, +it is still ambiguous. + +We also look up the non-fields with the same textual name + + 1. to throw an error if the user hasn't enabled DisambiguateRecordFields, + 2. in order to improve the error message when a user mistakenly tries to use + a non-field in a record update: + + f = () + e x = x { f = () } + +Unlike with constructors or pattern-matching, we do not allow the module +qualifier to be omitted from the field names, because we do not have a +data constructor to use to determine the appropriate qualifier. + +This is all done in the function lookupFieldGREs, which is called by +GHC.Rename.Pat.rnHsRecUpdFields, which deals with record updates. + +Note [Record field names and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12130): + + module Foo where + import M + b = $(funny) + + module M(funny) where + data T = MkT { x :: Int } + funny :: Q Exp + funny = [| MkT { x = 3 } |] + +When we splice, `MkT` is not lexically in scope, so +lookupGRE_FieldLabel will fail. But there is no need for +disambiguation anyway, because `x` is an original name, and +lookupGlobalOccRn will find it. +-} + +-- | Used in export lists to lookup the children. +lookupSubBndrOcc_helper :: Bool -> DeprecationWarnings + -> Name + -> RdrName -- ^ thing we are looking up + -> LookupChild -- ^ how to look it up (e.g. which + -- 'NameSpace's to look in) + -> RnM ChildLookupResult +lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name how_lkup + | isUnboundName parent + -- Avoid an error cascade + = return (FoundChild (mkUnboundGRERdr rdr_name)) + + | otherwise = do + gre_env <- getGlobalRdrEnv + let original_gres = lookupGRE gre_env (LookupChildren (rdrNameOcc rdr_name) how_lkup) + -- The remaining GREs are things that we *could* export here, note that + -- this includes things which have `NoParent`. Those are sorted in + -- `checkPatSynParent`. + traceRn "parent" (ppr parent) + traceRn "lookupExportChild original_gres:" (ppr original_gres) + traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent) + case picked_gres original_gres of + NoOccurrence -> + noMatchingParentErr original_gres + UniqueOccurrence g -> + if must_have_parent + then noMatchingParentErr original_gres + else checkFld g + DisambiguatedOccurrence g -> + checkFld g + AmbiguousOccurrence gres -> + mkNameClashErr gres + where + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g = do + addUsedGRE warn_if_deprec g + return $ FoundChild g + + -- Called when we find no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + traceRn "npe" (ppr original_gres) + dup_fields_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [g] -> return $ IncorrectParent parent g + [p | ParentIs p <- [greParent g]] + gss@(g:gss'@(_:_)) -> + if all isRecFldGRE gss && dup_fields_ok + then return $ + IncorrectParent parent g + [p | x <- gss, ParentIs p <- [greParent x]] + else mkNameClashErr $ g NE.:| gss' + + mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundChild (NE.head gres)) + + picked_gres :: [GlobalRdrElt] -> DisambigInfo + -- For Unqual, find GREs that are in scope qualified or unqualified + -- For Qual, find GREs that are in scope with that qualification + picked_gres gres + | isUnqual rdr_name + = mconcat (map right_parent gres) + | otherwise + = mconcat (map right_parent (pickGREs rdr_name gres)) + + right_parent :: GlobalRdrElt -> DisambigInfo + right_parent p + = case greParent p of + ParentIs cur_parent + | parent == cur_parent -> DisambiguatedOccurrence p + | otherwise -> NoOccurrence + NoParent -> UniqueOccurrence p +{-# INLINEABLE lookupSubBndrOcc_helper #-} + +-- This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurrence + -- The GRE could never be exported. It has the wrong parent. + | UniqueOccurrence GlobalRdrElt + -- The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurrence GlobalRdrElt + -- The parent of the GRE is the correct parent + | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt) + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurrence" and the + -- monoid will combine them to this failing case. + +instance Outputable DisambigInfo where + ppr NoOccurrence = text "NoOccurrence" + ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre + ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre + ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres + +instance Semi.Semigroup DisambigInfo where + -- This is the key line: We prefer disambiguated occurrences to other + -- names. + _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' + DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' + + NoOccurrence <> m = m + m <> NoOccurrence = m + UniqueOccurrence g <> UniqueOccurrence g' + = AmbiguousOccurrence $ g NE.:| [g'] + UniqueOccurrence g <> AmbiguousOccurrence gs + = AmbiguousOccurrence (g `NE.cons` gs) + AmbiguousOccurrence gs <> UniqueOccurrence g' + = AmbiguousOccurrence (g' `NE.cons` gs) + AmbiguousOccurrence gs <> AmbiguousOccurrence gs' + = AmbiguousOccurrence (gs Semi.<> gs') + +instance Monoid DisambigInfo where + mempty = NoOccurrence + mappend = (Semi.<>) + +-- Lookup SubBndrOcc can never be ambiguous +-- +-- Records the result of looking up a child. +data ChildLookupResult + -- | We couldn't find a suitable name + = NameNotFound + -- | The child has an incorrect parent + | IncorrectParent Name -- ^ parent + GlobalRdrElt -- ^ child we were looking for + [Name] -- ^ list of possible parents + -- | We resolved to a child + | FoundChild GlobalRdrElt + +instance Outputable ChildLookupResult where + ppr NameNotFound = text "NameNotFound" + ppr (FoundChild n) = text "Found:" <+> ppr (greParent n) <+> ppr n + ppr (IncorrectParent p g ns) + = text "IncorrectParent" + <+> hsep [ppr p, ppr $ greName g, ppr ns] + +lookupSubBndrOcc :: DeprecationWarnings + -> Name -- Parent + -> SDoc + -> RdrName + -> RnM (Either NotInScopeError Name) +-- ^ Find all the things the 'RdrName' maps to, +-- and pick the one with the right 'Parent' 'Name'. +lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = + lookupExactOrOrig rdr_name (Right . greName) $ + -- This happens for built-in classes, see mod052 for example + do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name what_lkup + ; return $ case child of + FoundChild g -> Right (greName g) + NameNotFound -> Left (UnknownSubordinate doc) + IncorrectParent {} -> Left (UnknownSubordinate doc) } + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + where + what_lkup = LookupChild { wantedParent = the_parent + , lookupDataConFirst = False + , prioritiseParent = True -- See T23664. + } +{- +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurrence +of 'G' in the 'instance C S' decl is unambiguous, because C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the enclosing instance decl, if any. + +Note [Looking up Exact RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames are generated by: + +* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs) +* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate) + +For data types and classes have Exact system Names in the binding +positions for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by GHC.ThToHs.thRdrName + +But, constructors and the like need External Names, not System Names! +So we do the following + + * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a + non-External Name, and make an External name for it. This is + the name that goes in the GlobalRdrEnv + + * When looking up an occurrence of an Exact name, done in + GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the + GlobalRdrEnv, and use the one from the envt -- it will be an + External Name in the case of the data type/constructor above. + + * Exact names are also use for purely local binders generated + by TH, such as \x_33. x_33 + Both binder and occurrence are Exact RdrNames. The occurrence + gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and + misses, because lookupLocalRdrEnv always returns Nothing for + an Exact Name. Now we fall through to lookupExactOcc, which + will find the Name is not in the GlobalRdrEnv, so we just use + the Exact supplied Name. + +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +The occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + +Note [Template Haskell ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GlobalRdrEnv invariant says that if + occ -> [gre1, ..., gren] +then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). +This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). + +So how can we get multiple gres in lookupExactOcc_maybe? Because in +TH we might use the same TH NameU in two different name spaces. +eg (#7241): + $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) +Here we generate a type constructor and data constructor with the same +unique, but different name spaces. + +It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would +mean looking up the OccName in every name-space, just in case, and that +seems a bit brutal. So it's just done here on lookup. But we might +need to revisit that choice. + +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + instance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualified M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- +-} + + +lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName + -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRn = wrapLocMA lookupOccRn + +lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName + -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr + +lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName + -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField + +lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName + -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone + +lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Just look in the local environment +lookupLocalOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrEnv local_env rdr_name) } + +lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) +-- Just look in the local environment +lookupLocalOccThLvl_maybe name + = do { lcl_env <- getLclEnv + ; return (lookupNameEnv (getLclEnvThBndrs lcl_env) name) } + +-- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to +-- determine what kind of suggestions should be displayed if it is not in scope +lookupOccRn' :: WhatLooking -> RdrName -> RnM Name +lookupOccRn' which_suggest rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> reportUnboundName' which_suggest rdr_name } + +-- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if +-- it is not in scope +lookupOccRn :: RdrName -> RnM Name +lookupOccRn = lookupOccRn' WL_Anything + +-- lookupOccRnConstr looks up an occurrence of a RdrName and displays +-- constructors and pattern synonyms as suggestions if it is not in scope +lookupOccRnConstr :: RdrName -> RnM Name +lookupOccRnConstr = lookupOccRn' WL_Constructor + +-- lookupOccRnRecField looks up an occurrence of a RdrName and displays +-- record fields as suggestions if it is not in scope +lookupOccRnRecField :: RdrName -> RnM Name +lookupOccRnRecField = lookupOccRn' WL_RecField + +-- lookupOccRnRecField looks up an occurrence of a RdrName and displays +-- no suggestions if it is not in scope +lookupOccRnNone :: RdrName -> RnM Name +lookupOccRnNone = lookupOccRn' WL_None + +-- Only used in one place, to rename pattern synonym binders. +-- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind +lookupLocalOccRn :: RdrName -> RnM Name +lookupLocalOccRn rdr_name + = do { mb_name <- lookupLocalOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name } + +-- lookupTypeOccRn looks up an optionally promoted RdrName. +-- Used for looking up type variables. +lookupTypeOccRn :: RdrName -> RnM Name +-- see Note [Demotion] +lookupTypeOccRn rdr_name + | (isVarOcc <||> isFieldOcc) (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] + = badVarInType rdr_name + | otherwise + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> + if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] + then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope + else lookup_demoted rdr_name } + +{- Note [eqTyCon (~) compatibility fallback] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before GHC Proposal #371, the (~) type operator used in type equality +constraints (a~b) was considered built-in syntax. + +This had two implications: + +1. Users could use it without importing it from Data.Type.Equality or Prelude. +2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead) + +To ease migration and minimize breakage, we continue to support those usages +but emit appropriate warnings. +-} + +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrName rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM LangExt.DataKinds + ; star_is_type <- xoptM LangExt.StarIsType + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + star_is_type_hints = noStarIsTypeHints is_star_type rdr_name + ; if data_kinds + then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr + ; case mb_demoted_gre of + Nothing -> unboundNameX looking_for rdr_name star_is_type_hints + Just demoted_gre -> return $ greName demoted_gre} + else do { -- We need to check if a data constructor of this name is + -- in scope to give good error messages. However, we do + -- not want to give an additional error if the data + -- constructor happens to be out of scope! See #13947. + mb_demoted_name <- discardErrs $ + lookupOccRn_maybe demoted_rdr + ; let suggestion | isJust mb_demoted_name + , let additional = text "to refer to the data constructor of that name?" + = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] + | otherwise + = star_is_type_hints + ; unboundNameX looking_for rdr_name suggestion } } + | Just demoted_rdr_name <- demoteRdrNameTv rdr_name, + isQual rdr_name + = report_qualified_term_in_types rdr_name demoted_rdr_name + + | otherwise + = reportUnboundName' (lf_which looking_for) rdr_name + + where + looking_for = LF WL_Constructor WL_Anywhere + +-- Report a qualified variable name in a type signature: +-- badSig :: Prelude.head +-- ^^^^^^^^^^^ +report_qualified_term_in_types :: RdrName -> RdrName -> RnM Name +report_qualified_term_in_types rdr_name demoted_rdr_name = + do { mName <- lookupGlobalOccRn_maybe (RelevantGREsFOS WantNormal) demoted_rdr_name + ; case mName of + (Just _) -> termNameInType looking_for rdr_name demoted_rdr_name [] + Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name } + where + looking_for = LF WL_Constructor WL_Global + +-- If the given RdrName can be promoted to the type level and its promoted variant is in scope, +-- lookup_promoted returns the corresponding type-level Name. +-- Otherwise, the function returns Nothing. +-- See Note [Promotion] below. +lookup_promoted :: RdrName -> RnM (Maybe GlobalRdrElt) +lookup_promoted rdr_name + | Just promoted_rdr <- promoteRdrName rdr_name + = lookupOccRn_maybe promoted_rdr + | otherwise + = return Nothing + +badVarInType :: RdrName -> RnM Name +badVarInType rdr_name + = do { addErr (TcRnUnpromotableThing name TermVariablePE) + ; return name } + where + name = mkUnboundNameRdr rdr_name + +{- Note [Promoted variables in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#12686): + x = True + data Bad = Bad 'x + +The parser treats the quote in 'x as saying "use the term +namespace", so we'll get (Bad x{v}), with 'x' in the +VarName namespace. If we don't test for this, the renamer +will happily rename it to the x bound at top level, and then +the typecheck falls over because it doesn't have 'x' in scope +when kind-checking. + +Note [Demotion] +~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurrence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) + +Another case of demotion happens when the user tries to +use a qualified term at the type level: + + f :: Prelude.id -> Int + +This signature passes the parser to be caught by the renamer. +It allows the compiler to create more informative error messages. + +'Prelude.id' in the type signature is parsed as + HsTyVar ("id", TvName) + +To separate the case of a typo from the case of an +intentional attempt to use an imported term's name the compiler demotes +the namespace to VarName (using 'demoteTvNameSpace') and does a lookup. + +The same type of demotion happens when the compiler needs to check +if a name of a type variable has already been used for a term that is in scope. +We need to do it to check if a user should change the name +to make his code compatible with the RequiredTypeArguments extension. + +Note [Promotion] +~~~~~~~~~~~~~~~ +When the user mentions a type constructor or a type variable in a +term-level context, then we report that a value identifier was expected +instead of a type-level one. That makes error messages more precise. +Previously, such errors contained only the info that a given value was out of scope (#18740). +We promote the namespace of RdrName and look up after that +(see the functions promotedRdrName and lookup_promoted). + +In particular, we have the following error message + • Illegal term-level use of the type constructor ‘Int’ + imported from ‘Prelude’ (and originally defined in ‘GHC.Types’) + • In the first argument of ‘id’, namely ‘Int’ + In the expression: id Int + In an equation for ‘x’: x = id Int + +when the user writes the following declaration + + x = id Int +-} + +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (GlobalRdrElt -> RnM r) -> RdrName + -> RnM (Maybe r) +lookupOccRnX_maybe globalLookup wrapper rdr_name + = runMaybeT . msum . map MaybeT $ + [ do { res <- lookupLocalOccRn_maybe rdr_name + ; case res of + { Nothing -> return Nothing + ; Just nm -> + -- Elements in the LocalRdrEnv are always Vanilla GREs + do { let gre = mkLocalVanillaGRE NoParent nm + ; Just <$> wrapper gre } } } + , globalLookup rdr_name ] + +lookupOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupOccRn_maybe = + lookupOccRnX_maybe + (lookupGlobalOccRn_maybe $ RelevantGREsFOS WantNormal) + return + +-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) +lookupSameOccRn_maybe :: RdrName -> RnM (Maybe Name) +lookupSameOccRn_maybe = + lookupOccRnX_maybe + (get_name <$> lookupGlobalOccRn_maybe SameNameSpace) + (return . greName) + where + get_name :: RnM (Maybe GlobalRdrElt) -> RnM (Maybe Name) + get_name = fmap (fmap greName) + +-- | Look up a 'RdrName' used as a variable in an expression. +-- +-- This may be a local variable, global variable, or one or more record selector +-- functions. It will not return record fields created with the +-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). +-- +-- If the name is not in scope at the term level, but its promoted equivalent is +-- in scope at the type level, the lookup will succeed (so that the type-checker +-- can report a more informative error later). See Note [Promotion]. +-- +lookupExprOccRn :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupExprOccRn rdr_name + = do { mb_name <- lookupOccRnX_maybe + lookupGlobalOccRn_overloaded + return + rdr_name + ; case mb_name of + Nothing -> lookup_promoted rdr_name + -- See Note [Promotion]. + -- We try looking up the name as a + -- type constructor or type variable, if + -- we failed to look up the name at the term level. + p -> return p } + +lookupGlobalOccRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Looks up a RdrName occurrence in the top-level +-- environment, including using lookupQualifiedNameGHCi +-- for the GHCi case, but first tries to find an Exact or Orig name. +-- No filter function; does not report an error on failure +-- See Note [Errors in lookup functions] +-- Uses addUsedRdrName to record use and deprecations +-- +-- Used directly only by getLocalNonValBinders (new_assoc). +lookupGlobalOccRn_maybe which_gres rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + lookupGlobalOccRn_base which_gres rdr_name + +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. Adds an error message if the RdrName is not in scope. +-- You usually want to use "lookupOccRn" which also looks in the local +-- environment. +-- +-- Used by exports_from_avail +lookupGlobalOccRn = lookupGlobalOccRn' (RelevantGREsFOS WantNormal) + +lookupGlobalOccRn' :: WhichGREs GREInfo -> RdrName -> RnM Name +lookupGlobalOccRn' which_gres rdr_name = + lookupExactOrOrig rdr_name greName $ do + mb_gre <- lookupGlobalOccRn_base which_gres rdr_name + case mb_gre of + Just gre -> return (greName gre) + Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) + ; unboundName (LF which_suggest WL_Global) rdr_name } + where which_suggest = case includeFieldSelectors which_gres of + WantBoth -> WL_RecField + WantField -> WL_RecField + WantNormal -> WL_Anything + +-- Looks up a RdrName occurrence in the GlobalRdrEnv and with +-- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. +-- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like +-- 'Data.Map.elems' is typed, even if you didn't import Data.Map +lookupGlobalOccRn_base :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_base which_gres rdr_name = + runMaybeT . msum . map MaybeT $ + [ lookupGreRn_maybe which_gres rdr_name + , lookupOneQualifiedNameGHCi fos rdr_name ] + -- This test is not expensive, + -- and only happens for failed lookups + where + fos = case which_gres of + RelevantGREs { includeFieldSelectors = sel } -> sel + _ -> if isFieldOcc (rdrNameOcc rdr_name) + then WantField + else WantNormal + +-- | Lookup a 'Name' in the 'GlobalRdrEnv', falling back to looking up +-- in the type environment it if fails. +lookupGREInfo_GRE :: HasDebugCallStack => Name -> RnM GREInfo +lookupGREInfo_GRE name + = do { rdr_env <- getGlobalRdrEnv + ; case lookupGRE_Name rdr_env name of + Just ( GRE { gre_info = info } ) + -> return info + _ -> do { hsc_env <- getTopEnv + ; return $ lookupGREInfo hsc_env name } } + -- Just looking in the GlobalRdrEnv is insufficient, as we also + -- need to handle qualified imports in GHCi; see e.g. T9815ghci. + +lookupInfoOccRn :: RdrName -> RnM [Name] +-- ^ lookupInfoOccRn is intended for use in GHCi's ":info" command +-- It finds all the GREs that RdrName could mean, not complaining +-- about ambiguity, but rather returning them all (c.f. #9881). +-- +-- lookupInfoOccRn is also used in situations where we check for +-- at least one definition of the RdrName, not complaining about +-- multiple definitions (see #17832). +lookupInfoOccRn rdr_name = + lookupExactOrOrig rdr_name (\ gre -> [greName gre]) $ + do { rdr_env <- getGlobalRdrEnv + ; let nms = map greName $ lookupGRE rdr_env (LookupRdrName rdr_name (RelevantGREsFOS WantBoth)) + ; qual_nms <- map greName <$> lookupQualifiedNameGHCi WantBoth rdr_name + ; return $ nms ++ (qual_nms `minusList` nms) } + +-- | Look up all record field names, available in the 'GlobalRdrEnv', +-- that a given 'RdrName' might refer to. +-- (Also includes implicit qualified imports in GHCi). +-- +-- Throws an error if no fields are found. +-- +-- See Note [DisambiguateRecordFields for updates]. +lookupFieldGREs :: GlobalRdrEnv -> LocatedN RdrName -> RnM (NE.NonEmpty FieldGlobalRdrElt) +lookupFieldGREs env (L loc rdr) + = setSrcSpanA loc + $ do { res <- lookupExactOrOrig rdr (\ gre -> maybeToList $ fieldGRE_maybe gre) $ + do { let (env_fld_gres, env_var_gres) = + partition isRecFldGRE $ + lookupGRE env (LookupRdrName rdr (RelevantGREsFOS WantBoth)) + + -- Handle implicit qualified imports in GHCi. See T10439. + ; ghci_gres <- lookupQualifiedNameGHCi WantBoth rdr + ; let (ghci_fld_gres, ghci_var_gres) = + partition isRecFldGRE $ + ghci_gres + + ; let fld_gres = ghci_fld_gres ++ env_fld_gres + var_gres = ghci_var_gres ++ env_var_gres + + -- Add an error for ambiguity when -XDisambiguateRecordFields is off. + -- + -- See Note [DisambiguateRecordFields for updates]. + ; disamb_ok <- xoptM LangExt.DisambiguateRecordFields + ; if | not disamb_ok + , gre1 : gre2 : others <- fld_gres ++ var_gres + -> addErrTc $ TcRnAmbiguousFieldInUpdate (gre1, gre2, others) + | otherwise + -> return () + ; return fld_gres } + + -- Add an error if lookup failed. + ; case res of + gre : gres -> return $ gre NE.:| gres + [] -> do { (imp_errs, hints) <- + unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr + ; failWithTc $ + TcRnNotInScope NotARecordField rdr imp_errs hints } } + +-- | Look up a 'RdrName', which might refer to an overloaded record field. +-- +-- Don't allow any ambiguity: emit a name-clash error if there are multiple +-- matching GREs. +lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_overloaded rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + do { res <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name AllDeprecationWarnings + ; case res of + GreNotFound -> lookupOneQualifiedNameGHCi WantNormal rdr_name + OneNameMatch gre -> return $ Just gre + MultipleNames gres@(gre NE.:| _) -> do + addNameClashErrRn rdr_name gres + return (Just gre) } + +getFieldUpdLbl :: LHsRecUpdField (GhcPass p) q -> LocatedN RdrName +getFieldUpdLbl = ambiguousFieldOccLRdrName . unLoc . hfbLHS . unLoc + +-- | Returns all possible collections of field labels for the given +-- record update. +-- +-- Example: +-- +-- data D = MkD { fld1 :: Int, fld2 :: Bool } +-- data E = MkE1 { fld1 :: Int, fld2 :: Bool, fld3 :: Char } +-- | MkE2 { fld1 :: Int, fld2 :: Bool } +-- data F = MkF1 { fld1 :: Int } | MkF2 { fld2 :: Bool } +-- +-- f r = r { fld1 = a, fld2 = b } +-- +-- This function will return: +-- +-- [ [ D.fld1, D.fld2 ] -- could be a record update at type D +-- , [ E.fld1, E.fld2 ] -- could be a record update at type E +-- ] -- cannot be a record update at type F: no constructor has both +-- -- of the fields fld1 and fld2 +-- +-- If there are no valid parents for the record update, +-- throws a 'TcRnBadRecordUpdate' error. +lookupRecUpdFields :: NE.NonEmpty (LHsRecUpdField GhcPs GhcPs) + -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) +lookupRecUpdFields flds +-- See Note [Disambiguating record updates] in GHC.Rename.Pat. + = do { -- Retrieve the possible GlobalRdrElts that each field could refer to. + ; gre_env <- getGlobalRdrEnv + ; fld1_gres NE.:| other_flds_gres <- mapM (lookupFieldGREs gre_env . getFieldUpdLbl) flds + -- Take an intersection: we are only interested in constructors + -- which have all of the fields. + ; let possible_GREs = intersect_by_cons fld1_gres other_flds_gres + + ; traceRn "lookupRecUpdFields" $ + vcat [ text "flds:" <+> ppr (fmap getFieldUpdLbl flds) + , text "possible_GREs:" <+> + ppr (map (fmap greName . rnRecUpdLabels) possible_GREs) ] + + ; case possible_GREs of + + -- There is at least one parent: we can proceed. + -- The typechecker might be able to finish disambiguating. + -- See Note [Type-directed record disambiguation] in GHC.Rename.Pat. + { p1:ps -> return (p1 NE.:| ps) + + -- There are no possible parents for the record update: compute + -- a minimum set of fields which does not belong to any data constructor, + -- to report an informative error to the user. + ; _ -> + let + -- The constructors which have the first field. + fld1_cons :: UniqSet ConLikeName + fld1_cons = unionManyUniqSets + $ NE.toList + $ NE.map (recFieldCons . fieldGREInfo) fld1_gres + -- The field labels of the constructors which have the first field. + fld1_cons_fields :: UniqFM ConLikeName [FieldLabel] + fld1_cons_fields + = fmap (lkp_con_fields gre_env) + $ getUniqSet fld1_cons + in failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } + + where + intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt + -> [NE.NonEmpty FieldGlobalRdrElt] + -> [HsRecUpdParent GhcRn] + intersect_by_cons this [] = + map + (\ fld -> RnRecUpdParent (fld NE.:| []) (recFieldCons (fieldGREInfo fld))) + (NE.toList this) + intersect_by_cons this (new : rest) = + [ RnRecUpdParent (this_fld NE.<| next_flds) both_cons + | this_fld <- NE.toList this + , let this_cons = recFieldCons $ fieldGREInfo this_fld + , RnRecUpdParent next_flds next_cons <- intersect_by_cons new rest + , let both_cons = next_cons `intersectUniqSets` this_cons + , not $ isEmptyUniqSet both_cons + ] + + lkp_con_fields :: GlobalRdrEnv -> ConLikeName -> [FieldLabel] + lkp_con_fields gre_env con = + [ fl + | let nm = conLikeName_Name con + , gre <- maybeToList $ lookupGRE_Name gre_env nm + , con_info <- maybeToList $ recFieldConLike_maybe gre + , fl <- conInfoFields con_info ] + +{-********************************************************************** +* * + Record field errors +* * +**********************************************************************-} + +getUpdFieldLbls :: forall p q. UnXRec (GhcPass p) + => [LHsRecUpdField (GhcPass p) q] -> [RdrName] +getUpdFieldLbls + = map $ ambiguousFieldOccRdrName + . unXRec @(GhcPass p) + . hfbLHS + . unXRec @(GhcPass p) + +-- | Create an error message when there is no single 'ConLike' which +-- has all of the required fields for a record update. +-- +-- This boils down the problem to a smaller set of fields, to avoid +-- the error message containing a lot of uninformative field names that +-- aren't really relevant to the problem. +-- +-- NB: this error message should only be triggered when all the field names +-- are in scope (i.e. each individual field name does belong to some +-- constructor in scope). +badFieldsUpd + :: (OutputableBndrId p) + => [LHsRecUpdField (GhcPass p) q] + -- ^ Field names that don't belong to a single datacon + -> UniqFM ConLikeName [FieldLabel] + -- ^ The list of field labels for each constructor. + -- (These are the constructors in which the first field occurs.) + -> TcRnMessage +badFieldsUpd rbinds fld1_cons_fields + = TcRnBadRecordUpdate + (getUpdFieldLbls rbinds) + (NoConstructorHasAllFields conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(FieldLabelString, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . head) $ groupBy ((==) `on` snd) growingSets + + aMember = assert (not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(FieldLabelString, [Bool])] + membership + = sortMembership $ + map + ( (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) + . FieldLabelString . occNameFS . rdrNameOcc . unLoc . getFieldUpdLbl ) + rbinds + + fieldLabelSets :: [UniqSet FieldLabelString] + fieldLabelSets = map (mkUniqSet . map flLabel) $ nonDetEltsUFM fld1_cons_fields + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = count id + +{- +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See #7989. +-} + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +data GreLookupResult = GreNotFound + | OneNameMatch GlobalRdrElt + | MultipleNames (NE.NonEmpty GlobalRdrElt) + +lookupGreRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Look up the RdrName in the GlobalRdrEnv +-- Exactly one binding: records it as "used", return (Just gre) +-- No bindings: return Nothing +-- Many bindings: report "ambiguous", return an arbitrary (Just gre) +-- Uses addUsedRdrName to record use and deprecations +lookupGreRn_maybe which_gres rdr_name + = do + res <- lookupGreRn_helper which_gres rdr_name AllDeprecationWarnings + case res of + OneNameMatch gre -> return $ Just gre + MultipleNames gres -> do + traceRn "lookupGreRn_maybe:NameClash" (ppr gres) + addNameClashErrRn rdr_name gres + return $ Just (NE.head gres) + GreNotFound -> return Nothing + +{- + +Note [ Unbound vs Ambiguous Names ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupGreRn_maybe deals with failures in two different ways. If a name +is unbound then we return a `Nothing` but if the name is ambiguous +then we raise an error and return a dummy name. + +The reason for this is that when we call `lookupGreRn_maybe` we are +speculatively looking for whatever we are looking up. If we don't find it, +then we might have been looking for the wrong thing and can keep trying. +On the other hand, if we find a clash then there is no way to recover as +we found the thing we were looking for but can no longer resolve which +the correct one is. + +One example of this is in `lookupTypeOccRn` which first looks in the type +constructor namespace before looking in the data constructor namespace to +deal with `DataKinds`. + +There is however, as always, one exception to this scheme. If we find +an ambiguous occurrence of a record selector and DuplicateRecordFields +is enabled then we defer the selection until the typechecker. + +-} + + +-- Internal Function +lookupGreRn_helper :: WhichGREs GREInfo -> RdrName -> DeprecationWarnings -> RnM GreLookupResult +lookupGreRn_helper which_gres rdr_name warn_if_deprec + = do { env <- getGlobalRdrEnv + ; case lookupGRE env (LookupRdrName rdr_name which_gres) of + [] -> return GreNotFound + [gre] -> do { addUsedGRE warn_if_deprec gre + ; return (OneNameMatch gre) } + -- Don't record usage for ambiguous names + -- until we know which is meant + (gre:others) -> return (MultipleNames (gre NE.:| others)) } + +lookupGreAvailRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Used in export lists +-- If not found or ambiguous, add error message, and fake with UnboundName +-- Uses addUsedRdrName to record use and deprecations +lookupGreAvailRn rdr_name + = do + mb_gre <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name ExportDeprecationWarnings + case mb_gre of + GreNotFound -> + do + traceRn "lookupGreAvailRn" (ppr rdr_name) + _ <- unboundName (LF WL_Anything WL_Global) rdr_name + return Nothing + MultipleNames gres -> + do + addNameClashErrRn rdr_name gres + return Nothing + -- Prevent error cascade + OneNameMatch gre -> + return $ Just gre + +{- +********************************************************* +* * + Deprecations +* * +********************************************************* + +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see #5867 and #4879) + +* We do not report deprecations for locally-defined names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* We also report deprecations at export sites, but only for names + deprecated with export deprecations (since those are not transitive as opposed + to regular name deprecations and are only reported at the importing module) + +* addUsedGREs: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' +-} + +addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () +-- Remember use of in-scope data constructors (#7969) +addUsedDataCons rdr_env tycon + = addUsedGREs NoDeprecationWarnings + [ gre + | dc <- tyConDataCons tycon + , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] + +-- | Whether to report deprecation warnings when registering a used GRE +-- +-- There is no option to only emit declaration warnings since everywhere +-- we emit the declaration warnings we also emit export warnings +-- (See Note [Handling of deprecations] for details) +data DeprecationWarnings + = NoDeprecationWarnings + | ExportDeprecationWarnings + | AllDeprecationWarnings + +addUsedGRE :: DeprecationWarnings -> GlobalRdrElt -> RnM () +-- Called for both local and imported things +-- Add usage *and* warn if deprecated +addUsedGRE warn_if_deprec gre + = do { condWarnIfDeprecated warn_if_deprec [gre] + ; when (isImportedGRE gre) $ -- See Note [Using isImportedGRE in addUsedGRE] + do { env <- getGblEnv + -- Do not report the GREInfo (#23424) + ; traceRn "addUsedGRE" (ppr $ greName gre) + ; updTcRef (tcg_used_gres env) (gre :) } } + +addUsedGREs :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () +-- Record uses of any *imported* GREs +-- Used for recording used sub-bndrs +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] +addUsedGREs warn_if_deprec gres + = do { condWarnIfDeprecated warn_if_deprec gres + ; unless (null imp_gres) $ + do { env <- getGblEnv + -- Do not report the GREInfo (#23424) + ; traceRn "addUsedGREs" (ppr $ map greName imp_gres) + ; updTcRef (tcg_used_gres env) (imp_gres ++) } } + where + imp_gres = filter isImportedGRE gres + -- See Note [Using isImportedGRE in addUsedGRE] + +{- Note [Using isImportedGRE in addUsedGRE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In addUsedGRE, we want to add any used imported GREs to the tcg_used_gres field, +so that we can emit appropriate warnings (see GHC.Rename.Names.warnUnusedImportDecls). + +We want to do this for GREs that were brought into scope through imports. As per +Note [GlobalRdrElt provenance] in GHC.Types.Name.Reader, this means we should +check that gre_imp is non-empty. Checking that gre_lcl is False is INCORRECT, +because we might have obtained the GRE by an Exact or Orig direct reference, +in which case we have both gre_lcl = False and gre_imp = emptyBag. + +Geting this wrong can lead to panics in e.g. bestImport, see #23240. +-} + +condWarnIfDeprecated :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () +condWarnIfDeprecated NoDeprecationWarnings _ = return () +condWarnIfDeprecated opt gres = do + this_mod <- getModule + let external_gres + = filterOut (nameIsLocalOrFrom this_mod . greName) gres + mapM_ (\gre -> warnIfExportDeprecated gre >> maybeWarnDeclDepr gre) external_gres + where + maybeWarnDeclDepr = case opt of + ExportDeprecationWarnings -> const $ return () + AllDeprecationWarnings -> warnIfDeclDeprecated + +warnIfDeclDeprecated :: GlobalRdrElt -> RnM () +warnIfDeclDeprecated gre@(GRE { gre_imp = iss }) + | Just imp_spec <- headMaybe iss + = do { dflags <- getDynFlags + ; when (wopt_any_custom dflags) $ + -- See Note [Handling of deprecations] + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeclDeprec iface gre of + Just deprText -> addDiagnostic $ + TcRnPragmaWarning { + pragma_warning_occ = occ, + pragma_warning_msg = deprText, + pragma_warning_import_mod = importSpecModule imp_spec, + pragma_warning_defined_mod = Just definedMod + } + Nothing -> return () } } + | otherwise + = return () + where + occ = greOccName gre + name = greName gre + definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" + +lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) +lookupImpDeclDeprec iface gre + -- Bleat if the thing, or its parent, is warn'd + = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` + case greParent gre of + ParentIs p -> mi_decl_warn_fn (mi_final_exts iface) (nameOccName p) + NoParent -> Nothing + +warnIfExportDeprecated :: GlobalRdrElt -> RnM () +warnIfExportDeprecated gre@(GRE { gre_imp = iss }) + = do { mod_warn_mbs <- mapBagM process_import_spec iss + ; for_ (sequence mod_warn_mbs) $ mapM + $ \(importing_mod, warn_txt) -> addDiagnostic $ + TcRnPragmaWarning { + pragma_warning_occ = occ, + pragma_warning_msg = warn_txt, + pragma_warning_import_mod = importing_mod, + pragma_warning_defined_mod = Nothing + } } + where + occ = greOccName gre + name = greName gre + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" + process_import_spec :: ImportSpec -> RnM (Maybe (ModuleName, WarningTxt GhcRn)) + process_import_spec is = do + let mod = is_mod $ is_decl is + iface <- loadInterfaceForModule doc mod + let mb_warn_txt = mi_export_warn_fn (mi_final_exts iface) name + return $ (moduleName mod, ) <$> mb_warn_txt + +{- +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + +********************************************************* +* * + GHCi support +* * +********************************************************* + +A qualified name on the command line can refer to any module at +all: we try to load the interface if we don't already have it, just +as if there was an "import qualified M" declaration for every +module. + +For example, writing `Data.List.sort` will load the interface file for +`Data.List` as if the user had written `import qualified Data.List`. + +If we fail we just return Nothing, rather than bleating +about "attempting to use module ‘D’ (./D.hs) which is not loaded" +which is what loadSrcInterface does. + +It is enabled by default and disabled by the flag +`-fno-implicit-import-qualified`. + +Note [Safe Haskell and GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We DON'T do this Safe Haskell as we need to check imports. We can +and should instead check the qualified import but at the moment +this requires some refactoring so leave as a TODO + +Note [DuplicateRecordFields and -fimplicit-import-qualified] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When DuplicateRecordFields is used, a single module can export the same OccName +multiple times, for example: + + module M where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + +Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an +ambiguity error. + +-} + +-- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an +-- ambiguity error if there are more than one. +lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupOneQualifiedNameGHCi fos rdr_name = do + all_gres <- lookupQualifiedNameGHCi fos rdr_name + case all_gres of + [] -> return Nothing + [gre] -> return $ Just $ gre + (gre:gres) -> + do addNameClashErrRn rdr_name (gre NE.:| gres) + return (Just (mkUnboundGRE $ greOccName gre)) + -- (Use mkUnboundGRE to get the correct namespace) + +-- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using +-- @-fimplicit-import-qualified@). This will normally be zero or one, but may +-- be more in the presence of @DuplicateRecordFields@. +lookupQualifiedNameGHCi :: HasDebugCallStack => FieldsOrSelectors -> RdrName -> RnM [GlobalRdrElt] +lookupQualifiedNameGHCi fos rdr_name + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { dflags <- getDynFlags + ; is_ghci <- getIsGHCi + ; go_for_it dflags is_ghci } + + where + go_for_it dflags is_ghci + | Just (mod_name,occ) <- isQual_maybe rdr_name + , let ns = occNameSpace occ + , is_ghci + , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour + , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] + = do { res <- loadSrcInterface_maybe doc mod_name NotBoot NoPkgQual + ; case res of + Succeeded iface + -> do { hsc_env <- getTopEnv + ; let gres = + [ gre + | avail <- mi_exports iface + , gname <- availNames avail + , let lk_occ = occName gname + lk_ns = occNameSpace lk_occ + , occNameFS occ == occNameFS lk_occ + , ns == lk_ns || (ns == varName && isFieldNameSpace lk_ns) + , let mod = mi_module iface + gre = lookupGRE_PTE mod hsc_env gname + , allowGRE fos gre + -- Include a field if it has a selector or we are looking for all fields; + -- see Note [NoFieldSelectors]. + ] + ; return gres } + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) + ; return [] } } + + | otherwise + = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) + ; return [] } + + doc = text "Need to find" <+> ppr rdr_name + + -- Lookup a Name for an implicit qualified import in GHCi + -- in the given PackageTypeEnv. + lookupGRE_PTE :: Module -> HscEnv -> Name -> GlobalRdrElt + lookupGRE_PTE mod hsc_env nm = + -- Fake a GRE so we can report a sensible name clash error if + -- -fimplicit-import-qualified is used with a module that exports the same + -- field name multiple times (see + -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). + GRE { gre_name = nm + , gre_par = NoParent + , gre_lcl = False + , gre_imp = unitBag is + , gre_info = info } + where + info = lookupGREInfo hsc_env nm + spec = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, is_qual = True, is_dloc = noSrcSpan } + is = ImpSpec { is_decl = spec, is_item = ImpAll } + +-- | Look up the 'GREInfo' associated with the given 'Name' +-- by looking up in the type environment. +lookupGREInfo :: HasDebugCallStack => HscEnv -> Name -> GREInfo +lookupGREInfo hsc_env nm + | Just ty_thing <- wiredInNameTyThing_maybe nm + = tyThingGREInfo ty_thing + | otherwise + -- Create a thunk which, when forced, loads the interface + -- and looks up the TyThing in the type environment. + -- + -- See Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. + = case nameModule_maybe nm of + Nothing -> UnboundGRE + Just mod -> + unsafePerformIO $ do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "lookupGREInfo" <+> parens (ppr nm)) + mod ImportBySystem + mb_ty_thing <- lookupType hsc_env nm + case mb_ty_thing of + Nothing -> pprPanic "lookupGREInfo" $ + vcat [ text "lookup failed:" <+> ppr nm ] + Just ty_thing -> return $ tyThingGREInfo ty_thing + +{- +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupSigOccRn is used for type signatures and pragmas +Is this valid? + module A + import M( f ) + f :: Int -> Int + f x = x +It's clear that the 'f' in the signature must refer to A.f +The Haskell98 report does not stipulate this, but it will! +So we must treat the 'f' in the signature in the same way +as the binding occurrence of 'f', using lookupBndrRn + +However, consider this case: + import M( f ) + f :: Int -> Int + g x = x +We don't want to say 'f' is out of scope; instead, we want to +return the imported 'f', so that later on the renamer will +correctly report "misplaced type sig". + +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* For type signatures the NameSet should be the names bound by the + value bindings; for fixity declarations, the NameSet should also + include class sigs and record selectors + + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a +-} + +data HsSigCtxt + = TopSigCtxt NameSet -- At top level, binding these names + -- See Note [Signatures for top level things] + | LocalBindCtxt NameSet -- In a local binding, binding these names + | ClsDeclCtxt Name -- Class decl for this class + | InstDeclCtxt NameSet -- Instance decl whose user-written method + -- bindings are for these methods + | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names + | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types + -- in the group + +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + +lookupSigOccRn :: HsSigCtxt + -> Sig GhcPs + -> LocatedA RdrName -> RnM (LocatedA Name) +lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) + +lookupSigOccRnN :: HsSigCtxt + -> Sig GhcPs + -> LocatedN RdrName -> RnM (LocatedN Name) +lookupSigOccRnN ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) + +-- | Lookup a name in relation to the names in a 'HsSigCtxt' +lookupSigCtxtOccRn :: HsSigCtxt + -> SDoc -- ^ description of thing we're looking up, + -- like "type family" + -> GenLocated (SrcSpanAnn' ann) RdrName + -> RnM (GenLocated (SrcSpanAnn' ann) Name) +lookupSigCtxtOccRn ctxt what + = wrapLocMA $ \ rdr_name -> + do { let also_try_tycons = False + ; mb_names <- lookupBindGroupOcc ctxt what rdr_name also_try_tycons + ; case mb_names of + Right name NE.:| rest -> + do { massertPpr (null rest) $ + vcat (text "lookupSigCtxtOccRn" <+> ppr name : map (either (pprScopeError rdr_name) ppr) rest) + ; return name } + Left err NE.:| _ -> + do { addErr (mkTcRnNotInScope rdr_name err) + ; return (mkUnboundNameRdr rdr_name) } + } + +lookupBindGroupOcc :: HsSigCtxt + -> SDoc + -> RdrName -- ^ what to look up + -> Bool -- ^ if the 'RdrName' we are looking up is in + -- a value 'NameSpace', should we also look up + -- in the type constructor 'NameSpace'? + -> RnM (NE.NonEmpty (Either NotInScopeError Name)) +-- ^ Looks up the 'RdrName', expecting it to resolve to one of the +-- bound names currently in scope. If not, return an appropriate error message. +-- +-- See Note [Looking up signature names]. +lookupBindGroupOcc ctxt what rdr_name also_try_tycon_ns + | Just n <- isExact_maybe rdr_name + = do { mb_gre <- lookupExactOcc_either n + ; return $ case mb_gre of + Left err -> NE.singleton $ Left err + Right gre -> finish (NoExactName $ greName gre) gre } + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { NE.singleton . Right <$> lookupOrig rdr_mod rdr_occ } + + | otherwise + = case ctxt of + HsBootCtxt ns -> lookup_top (`elemNameSet` ns) + TopSigCtxt ns -> lookup_top (`elemNameSet` ns) + RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 + then return $ NE.singleton $ Right $ mkUnboundNameRdr rdr_name + else lookup_top (`elemNameSet` ns) + where + + ns = occNameSpace occ + occ = rdrNameOcc rdr_name + relevant_gres = + RelevantGREs + { includeFieldSelectors = WantBoth + , lookupVariablesForFields = True + , lookupTyConsAsWell = also_try_tycon_ns } + ok_gre = greIsRelevant relevant_gres ns + + finish err gre + | ok_gre gre + = NE.singleton (Right $ greName gre) + | otherwise + = NE.singleton (Left err) + + lookup_cls_op cls + = NE.singleton <$> lookupSubBndrOcc AllDeprecationWarnings cls doc rdr_name + where + doc = text "method of class" <+> quotes (ppr cls) + + lookup_top keep_me + = do { env <- getGlobalRdrEnv + ; let occ = rdrNameOcc rdr_name + all_gres = lookupGRE env (LookupOccName occ relevant_gres) + names_in_scope = -- If rdr_name lacks a binding, only + -- recommend alternatives from relevant + -- namespaces. See #17593. + map greName + $ filter (ok_gre <&&> isLocalGRE) + $ globalRdrEnvElts env + candidates_msg = candidates names_in_scope + ; case filter (keep_me . greName) all_gres of + [] | null all_gres -> bale_out_with candidates_msg + | otherwise -> bale_out_with local_msg + (gre1:gres) -> return (fmap (Right . greName) (gre1 NE.:| gres)) } + + lookup_group bound_names -- Look in the local envt (not top level) + = do { mname <- lookupLocalOccRn_maybe rdr_name + ; env <- getLocalRdrEnv + ; let candidates_msg = candidates $ localRdrEnvElts env + ; case mname of + Just n + | n `elemNameSet` bound_names -> return $ NE.singleton $ Right n + | otherwise -> bale_out_with local_msg + Nothing -> bale_out_with candidates_msg } + + bale_out_with hints = return $ NE.singleton $ Left $ MissingBinding what hints + + local_msg = [SuggestMoveToDeclarationSite what rdr_name] + + -- Identify all similar names and produce a message listing them + candidates :: [Name] -> [GhcHint] + candidates names_in_scope + | (nm : nms) <- map SimilarName similar_names + = [SuggestSimilarNames rdr_name (nm NE.:| nms)] + | otherwise + = [] + where + similar_names + = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) + names_in_scope + + +--------------- +lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames ctxt what rdr + = do { this_mod <- getModule + ; let also_try_tycon_ns = True + ; nms_eithers <- fmap (guard_builtin_syntax this_mod rdr) <$> + lookupBindGroupOcc ctxt what rdr also_try_tycon_ns + ; let (errs, names) = partitionEithers (NE.toList nms_eithers) + ; when (null names) $ + addErr (head errs) -- Bleat about one only + ; return names } + where + -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 + guard_builtin_syntax this_mod rdr (Right name) + | Just _ <- isBuiltInOcc_maybe (occName rdr) + , this_mod /= nameModule name + = Left $ TcRnIllegalBuiltinSyntax what rdr + | otherwise + = Right (rdr, name) + guard_builtin_syntax _ _ (Left err) + = Left $ mkTcRnNotInScope rdr err + +dataTcOccs :: RdrName -> [RdrName] +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] +dataTcOccs rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + +{- Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. +-} + +{- +************************************************************************ +* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_RebindableSyntax dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + +* * +************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional/HsIsString + * NegApp + * NPlusKPat + * HsDo +respectively. Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. + +We treat the original (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. +-} + +lookupIfThenElse :: RnM (Maybe Name) +-- Looks up "ifThenElse" if rebindable syntax is on +lookupIfThenElse + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on + then return Nothing + else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just ite) } } + +lookupSyntaxName :: Name -- ^ The standard name + -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name +-- Lookup a Name that may be subject to Rebindable Syntax (RS). +-- +-- - When RS is off, just return the supplied (standard) Name +-- +-- - When RS is on, look up the OccName of the supplied Name; return +-- what we find, or the supplied Name if there is nothing in scope +lookupSyntaxName std_name + = do { rebind <- xoptM LangExt.RebindableSyntax + ; if not rebind + then return (std_name, emptyFVs) + else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name)) + ; return (nm, unitFV nm) } } + +lookupSyntaxExpr :: Name -- ^ The standard name + -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxExpr std_name + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (nl_HsVar name, fvs) } + +lookupSyntax :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name +lookupSyntax std_name + = do { (expr, fvs) <- lookupSyntaxExpr std_name + ; return (mkSyntaxExpr expr, fvs) } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames + -- this works with CmdTop, which wants HsExprs, not SyntaxExprs +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (map (HsVar noExtField . noLocA) std_names, emptyFVs) + else + do { usr_names <- + mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names + ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } } + + +{- +Note [QualifiedDo] +~~~~~~~~~~~~~~~~~~ +QualifiedDo is implemented using the same placeholders for operation names in +the AST that were devised for RebindableSyntax. Whenever the renamer checks +which names to use for do syntax, it first checks if the do block is qualified +(e.g. M.do { stmts }), in which case it searches for qualified names. If the +qualified names are not in scope, an error is produced. If the do block is not +qualified, the renamer does the usual search of the names which considers +whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven +by the Opt_QualifiedDo dynamic flag. +-} + +-- Lookup operations for a qualified do. If the context is not a qualified +-- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. +lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupQualifiedDoExpr ctxt std_name + = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name + +-- Like lookupQualifiedDoExpr but for producing SyntaxExpr. +-- See Note [QualifiedDo]. +lookupQualifiedDo + :: HsStmtContext p + -> Name + -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupQualifiedDo ctxt std_name + = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name + +lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) +lookupNameWithQualifier std_name modName + = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name)) + ; return (qname, unitFV qname) } + +-- See Note [QualifiedDo]. +lookupQualifiedDoName + :: HsStmtContext p + -> Name + -> RnM (Name, FreeVars) +lookupQualifiedDoName ctxt std_name + = case qualifiedDoModuleName_maybe ctxt of + Nothing -> lookupSyntaxName std_name + Just modName -> lookupNameWithQualifier std_name modName 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 @@ -47,14 +47,16 @@ , checkUnusedRecordWildcard , wrapGenSpan, genHsIntegralLit, genHsTyLit , genHsVar, genLHsVar, genHsApp, genHsApps - , genAppType ) + , genAppType, isIrrefutableHsPatRn ) import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName ) import GHC.Rename.HsType import GHC.Rename.Pat -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Builtin.Names +import GHC.Builtin.Types ( nilDataConName ) +import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel import GHC.Types.Fixity import GHC.Types.Id.Make @@ -63,22 +65,22 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.Set import GHC.Types.SourceText +import GHC.Types.SrcLoc import GHC.Utils.Misc -import GHC.Data.List.SetOps ( removeDups ) +import GHC.Data.List.SetOps ( removeDupsOn ) +import GHC.Data.Maybe import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable -import GHC.Types.SrcLoc -import Control.Monad -import GHC.Builtin.Types ( nilDataConName ) + import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Control.Monad import Data.List (unzip4, minimumBy) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) -import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord import Data.Array @@ -254,28 +256,33 @@ rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags - ; mb_name <- lookupExprOccRn v - - ; case mb_name of { + ; mb_gre <- lookupExprOccRn v + ; case mb_gre of { Nothing -> rnUnboundVar v ; - Just (NormalGreName name) - | name == nilDataConName -- Treat [] as an ExplicitList, so that - -- OverloadedLists works correctly - -- Note [Empty lists] in GHC.Hs.Expr - , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noAnn []) + Just gre -> + do { let nm = greName gre + info = greInfo gre + ; if | IAmRecField fld_info <- info + -- Since GHC 9.4, such occurrences of record fields must be + -- unambiguous. For ambiguous occurrences, we arbitrarily pick one + -- matching GRE and add a name clash error + -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). + -> do { let sel_name = flSelector $ recFieldLabel fld_info + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod sel_name) $ + checkThLocalName sel_name + ; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) + } + | nm == nilDataConName + -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -- Note [Empty lists] in GHC.Hs.Expr + , xopt LangExt.OverloadedLists dflags + -> rnExpr (ExplicitList noAnn []) - | otherwise - -> finishHsVar (L (na2la l) name) ; - Just (FieldGreName fl) - -> do { let sel_name = flSelector fl - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod sel_name) $ - checkThLocalName sel_name - ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) - } - } - } + | otherwise + -> finishHsVar (L (na2la l) nm) + }}} rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) @@ -320,7 +327,7 @@ rnExpr (HsAppType _ fun at arg) = do { type_app <- xoptM LangExt.TypeApplications - ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg + ; unless type_app $ addErr $ typeAppErr TypeLevel $ hswc_body arg ; (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg ; return (HsAppType NoExtField fun' at arg', fvFun `plusFV` fvArg) } @@ -421,7 +428,7 @@ rnExpr (HsCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCase CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) } rnExpr (HsLet _ tkLet binds tkIn expr) = rnLocalBindsAndThen binds $ \binds' _ -> do @@ -477,30 +484,43 @@ rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld) ; return (L l (fld { hfbRHS = arg' }), fvs) } -rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = case rbinds of - Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update. - do { ; (e, fv_e) <- rnLExpr expr - ; (rs, fv_rs) <- rnHsRecUpdFields flds - ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs ) - } - Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. - do { ; unlessXOptM LangExt.RebindableSyntax $ - addErr TcRnNoRebindableSyntaxRecordDot - ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] - ; punsEnabled <-xoptM LangExt.NamedFieldPuns - ; unless (null punnedFields || punsEnabled) $ - addErr TcRnNoFieldPunsRecordDot - ; (getField, fv_getField) <- lookupSyntaxName getFieldName - ; (setField, fv_setField) <- lookupSyntaxName setFieldName - ; (e, fv_e) <- rnLExpr expr - ; (us, fv_us) <- rnHsUpdProjs flds - ; return ( mkExpandedExpr - (RecordUpd noExtField e (Right us)) - (mkRecordDotUpd getField setField e us) - , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) - } +rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) + = setSrcSpanA l $ + case rbinds of + -- 'OverloadedRecordUpdate' is not in effect. Regular record update. + RegularRecUpdFields { recUpdFields = flds } -> + do { (e, fv_e) <- rnExpr expr + ; (parents, flds, fv_flds) <- rnHsRecUpdFields flds + ; let upd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = flds } + ; return ( RecordUpd noExtField (L l e) upd_flds + , fv_e `plusFV` fv_flds ) } + + -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. + OverloadedRecUpdFields { olRecUpdFields = flds } -> + do { unlessXOptM LangExt.RebindableSyntax $ + addErr TcRnNoRebindableSyntaxRecordDot + ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] + ; punsEnabled <- xoptM LangExt.NamedFieldPuns + ; unless (null punnedFields || punsEnabled) $ + addErr TcRnNoFieldPunsRecordDot + ; (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (setField, fv_setField) <- lookupSyntaxName setFieldName + ; (e, fv_e) <- rnExpr expr + ; (us, fv_us) <- rnHsUpdProjs flds + ; let upd_flds = OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = us } + ; return ( mkExpandedExpr + (RecordUpd noExtField (L l e) upd_flds) + (mkRecordDotUpd getField setField (L l e) us) + , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) } + +rnExpr (HsRecSel x _) = dataConCantHappen x + rnExpr (ExprWithTySig _ expr pty) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ @@ -569,8 +589,8 @@ (expr',fvExpr) <- rnLExpr expr stage <- getStage case stage of - Splice _ -> addErr $ TcRnIllegalStaticFormInSplice e - _ -> return () + Splice _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e + _ -> return () mod <- getModule let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr return (HsStatic fvExpr' expr', fvExpr) @@ -588,9 +608,6 @@ { (body',fvBody) <- rnCmdTop body ; return (HsProc x pat' body', fvBody) } -rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsWrap - {- ************************************************************************ * * @@ -1306,7 +1323,7 @@ -> [Name] -> [ParStmtBlock GhcPs GhcPs] -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) rn_segs _ bndrs_so_far [] - = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far + = do { let (bndrs', dups) = removeDupsOn nameOccName bndrs_so_far ; mapM_ dupErr dups ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } @@ -1322,7 +1339,6 @@ ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs) lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) @@ -2308,7 +2324,7 @@ hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat , is_body_stmt = False}) = - not (isIrrefutableHsPat dflags pat) + not (isIrrefutableHsPatRn dflags pat) hasRefutablePattern _ _ = False isLetStmt :: LStmt (GhcPass a) b -> Bool @@ -2616,7 +2632,7 @@ dflags <- getDynFlags -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) -- we should not need to fail. - if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs) + if | isIrrefutableHsPatRn dflags pat -> return (Nothing, emptyFVs) -- For non-monadic contexts (e.g. guard patterns, list -- comprehensions, etc.) we should not need to fail, or failure is handled in @@ -2777,4 +2793,4 @@ hfbAnn = noAnn , hfbLHS = fmap rnFieldLabelStrings fs , hfbRHS = arg - , hfbPun = pun}), fv ) } + , hfbPun = pun }), fv ) } diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -24,7 +24,6 @@ import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Reader import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc @@ -107,10 +106,7 @@ -} lookupFixityRn :: Name -> RnM Fixity -lookupFixityRn name = lookupFixityRn' name (nameOccName name) - -lookupFixityRn' :: Name -> OccName -> RnM Fixity -lookupFixityRn' name = fmap snd . lookupFixityRn_help' name +lookupFixityRn = fmap snd . lookupFixityRn_help -- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' -- in a local environment or from an interface file. Otherwise, it returns @@ -118,13 +114,7 @@ -- user-supplied fixity declarations). lookupFixityRn_help :: Name -> RnM (Bool, Fixity) -lookupFixityRn_help name = - lookupFixityRn_help' name (nameOccName name) - -lookupFixityRn_help' :: Name - -> OccName - -> RnM (Bool, Fixity) -lookupFixityRn_help' name occ +lookupFixityRn_help name | isUnboundName name = return (False, Fixity NoSourceText minPrecedence InfixL) -- Minimise errors from unbound names; eg @@ -144,6 +134,7 @@ then return (False, defaultFixity) else lookup_imported } } } where + occ = nameOccName name lookup_imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back @@ -180,10 +171,5 @@ lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc --- | Look up the fixity of an occurrence of a record field selector. --- We use 'lookupFixityRn'' so that we can specify the 'OccName' as --- the field label, which might be different to the 'OccName' of the --- selector 'Name' if @DuplicateRecordFields@ is in use (#1173). lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (FieldOcc n lrdr) - = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) +lookupFieldFixityRn (FieldOcc n _) = lookupFixityRn n 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 @@ module GHC.Rename.HsType ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext, - rnHsKind, rnLHsKind, rnLHsTypeArgs, + rnLHsKind, rnLHsTypeArgs, rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars, HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, newTyVarNameRn, @@ -45,19 +45,17 @@ import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) -import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env import GHC.Rename.Doc import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV - , typeAppErr, newLocalBndrRn, checkDupRdrNamesN + , typeAppErr, newLocalBndrRn, checkDupRdrNames , checkShadowedRdrNames, warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr ( pprScopeError - , inHsDocContext, pprHsDocContext ) +import GHC.Tc.Errors.Ppr ( pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names @@ -215,14 +213,7 @@ -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided, -- so we currently reject. when (not (null varsInScope)) $ - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat - [ text "Type variable" <> plural varsInScope - <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope)) - <+> isOrAre varsInScope - <+> text "already in scope." - , text "Type applications in patterns must bind fresh variables, without shadowing." - ] + addErr $ TcRnBindVarAlreadyInScope varsInScope (wcVars, ibVars) <- partition_nwcs varsNotInScope rnImplicitTvBndrs ctxt Nothing ibVars $ \ ibVars' -> do (wcVars', hs_ty', fvs) <- rnWcBody ctxt wcVars hs_ty @@ -371,7 +362,7 @@ = setSrcSpanA loc $ do { traceRn "rnHsSigType" (ppr sig_ty) ; case outer_bndrs of - HsOuterExplicit{} -> checkPolyKinds env sig_ty + HsOuterExplicit{} -> checkPolyKinds env (HsSigType sig_ty) HsOuterImplicit{} -> pure () ; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' -> @@ -403,7 +394,7 @@ -- See Note [Source locations for implicitly bound type variables]. ; loc <- getSrcSpanM ; let loc' = noAnnSrcSpan loc - ; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs + ; vars <- mapM (newTyVarNameRnImplicit mb_assoc . L loc' . unLoc) implicit_vs ; bindLocalNamesFV vars $ thing_inside vars } @@ -446,9 +437,7 @@ = do { implicit_vs <- forM (NE.groupAllWith unLoc $ implicit_vs_with_dups) $ \case (x :| []) -> return x (x :| _) -> do - let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "." - addErr msg + addErr $ TcRnBindMultipleVariables ctx x return x ; traceRn "rnImplicitTvBndrs" $ @@ -468,35 +457,6 @@ {- rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. - -Note [HsQualTy in kinds] -~~~~~~~~~~~~~~~~~~~~~~ -I was wondering whether HsQualTy could occur only at TypeLevel. But no, -we can have a qualified type in a kind too. Here is an example: - - type family F a where - F Bool = Nat - F Nat = Type - - type family G a where - G Type = Type -> Type - G () = Nat - - data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where - MkX :: X 'True '() - -See that k1 becomes Bool and k2 becomes (), so the equality is -satisfied. If I write MkX :: X 'True 'False, compilation fails with a -suitable message: - - MkX :: X 'True '() - • Couldn't match kind ‘G Bool’ with ‘Nat’ - Expected kind: G Bool - Actual kind: F Bool - -However: in a kind, the constraints in the HsQualTy must all be -equalities; or at least, any kinds with a class constraint are -uninhabited. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep. -} data RnTyKiEnv @@ -552,9 +512,6 @@ rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) -rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind - -- renaming a type only, not a kind rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars) @@ -603,18 +560,18 @@ rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau }) - = do { checkPolyKinds env ty + = do { checkPolyKinds env (HsType ty) ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> do { (tau', fvs) <- rnLHsTyKi env tau ; return ( HsForAllTy { hst_xforall = noExtField , hst_tele = tele' , hst_body = tau' } , fvs) } } -rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) - = do { data_kinds <- xoptM LangExt.DataKinds -- See Note [HsQualTy in kinds] - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env ty)) - ; (ctxt', fvs1) <- rnTyKiContext env lctxt +rnHsTyKi env (HsQualTy { hst_ctxt = lctxt, hst_body = tau }) + = do { -- no need to check type vs kind level here; this is + -- checked in the type checker. See + -- Note [No constraints in kinds] in GHC.Tc.Validity + (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' , hst_body = tau' } @@ -624,9 +581,7 @@ = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) - , text "Perhaps you intended to use PolyKinds" ] + TcRnUnexpectedKindVar rdr_name -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name @@ -662,12 +617,18 @@ ; return (HsRecTy noExtField flds', fvs) } where get_fields (ConDeclCtx names) - = concatMapM (lookupConstructorFields . unLoc) names - get_fields _ - = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "Record syntax is illegal here:") 2 (ppr ty)) - ; return [] } + = do res <- concatMapM (lookupConstructorFields . unLoc) names + if equalLength res names + -- Lookup can fail when the record syntax is incorrect, e.g. + -- data D = D Int { fld :: Bool }. See T7943. + then return res + else err + get_fields _ = err + err = + do { addErr $ TcRnIllegalRecordSyntax (Left ty) + ; return [] } + rnHsTyKi env (HsFunTy u mult ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 @@ -685,8 +646,9 @@ rnHsTyKi env (HsKindSig x ty k) = do { kind_sigs_ok <- xoptM LangExt.KindSignatures ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) - ; (ty', lhs_fvs) <- rnLHsTyKi env ty ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k + ; (ty', lhs_fvs) <- bindSigTyVarsFV (hsScopedKvs k') $ + rnLHsTyKi env ty ; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These @@ -709,28 +671,25 @@ rnHsTyKi env tyLit@(HsTyLit src t) = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env tyLit)) - ; when (negLit t) (addErr negLitErr) + ; when (negLit t) (addErr $ TcRnNegativeNumTypeLiteral tyLit) ; return (HsTyLit src (rnHsTyLit t), emptyFVs) } where negLit :: HsTyLit (GhcPass p) -> Bool negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLit (HsCharTy _ _) = False - negLitErr :: TcRnMessage - negLitErr = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit rnHsTyKi env (HsAppTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsAppKindTy l ty k) +rnHsTyKi env (HsAppKindTy _ ty at k) = do { kind_app <- xoptM LangExt.TypeApplications - ; unless kind_app (addErr (typeAppErr "kind" k)) + ; unless kind_app (addErr (typeAppErr KindLevel k)) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } + ; return (HsAppKindTy noExtField ty' at k', fvs1 `plusFV` fvs2) } rnHsTyKi env t@(HsIParamTy x n ty) = do { notInKinds env t @@ -759,12 +718,10 @@ check_in_scope :: RdrName -> RnM () check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name - -- TODO: refactor this to avoid mkTcRnUnknownMessage when (isNothing mb_name) $ addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name) + TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name [] [] rnHsTyKi env ty@(HsExplicitListTy _ ip tys) = do { data_kinds <- xoptM LangExt.DataKinds @@ -919,27 +876,22 @@ --------------- -- | Ensures either that we're in a type or that -XPolyKinds is set -checkPolyKinds :: Outputable ty - => RnTyKiEnv - -> ty -- ^ type - -> RnM () +checkPolyKinds :: RnTyKiEnv + -> HsTypeOrSigType GhcPs + -> RnM () checkPolyKinds env ty | isRnKindLevel env = do { polykinds <- xoptM LangExt.PolyKinds ; unless polykinds $ - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable PolyKinds?") } + addErr $ TcRnIllegalKind ty True } checkPolyKinds _ _ = return () -notInKinds :: Outputable ty - => RnTyKiEnv - -> ty +notInKinds :: RnTyKiEnv + -> HsType GhcPs -> RnM () notInKinds env ty | isRnKindLevel env - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal kind:" <+> ppr ty + = addErr $ TcRnIllegalKind (HsType ty) False notInKinds _ _ = return () {- ***************************************************** @@ -967,8 +919,8 @@ -> Maybe a -- Just _ => an associated type decl -> FreeKiTyVars -- Kind variables from scope -> LHsQTyVars GhcPs - -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) - -- The Bool is True <=> all kind variables used in the + -> (LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars)) + -- The FreeKiTyVars is null <=> all kind variables used in the -- kind signature are bound on the left. Reason: -- the last clause of Note [CUSKs: complete user-supplied kind signatures] -- in GHC.Hs.Decls @@ -991,7 +943,6 @@ bndr_kv_occs ++ body_kv_occs body_remaining = filterFreeVarsToBind bndr_kv_occs $ filterFreeVarsToBind bndrs body_kv_occs - all_bound_on_lhs = null body_remaining ; traceRn "checkMixedVars3" $ vcat [ text "bndrs" <+> ppr hs_tv_bndrs @@ -1006,7 +957,8 @@ -- This is the only call site for bindLHsTyVarBndrs where we pass -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings. -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars]. - do { let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will + do { rn_bndrs <- traverse rnLHsTyVarBndrVisFlag rn_bndrs + ; let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will -- span the entire declaration to which the LHsQTyVars belongs, -- which will be reflected in warning and error messages. We can -- be a little more precise than that by pointing to the location @@ -1017,7 +969,7 @@ ; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms , hsq_explicit = rn_bndrs }) - all_bound_on_lhs } } + body_remaining } } where hs_tv_bndrs = hsQTvExplicit hsq_bndrs @@ -1034,7 +986,7 @@ -- The in-tree API annotations extend the LHsTyVarBndr location to -- include surrounding parens. for error messages to be -- compatible, we recreate the location from the contents - get_bndr_loc :: LHsTyVarBndr () GhcPs -> SrcSpan + get_bndr_loc :: LHsTyVarBndr flag GhcPs -> SrcSpan get_bndr_loc (L _ (UserTyVar _ _ ln)) = getLocA ln get_bndr_loc (L _ (KindedTyVar _ _ ln lk)) = combineSrcSpans (getLocA ln) (getLocA lk) @@ -1183,6 +1135,21 @@ thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField , hso_bndrs = exp_bndrs' } +-- See Note [Term variable capture and implicit quantification] +warn_term_var_capture :: LocatedN RdrName -> RnM () +warn_term_var_capture lVar = do + gbl_env <- getGlobalRdrEnv + local_env <- getLocalRdrEnv + case demoteRdrNameTv $ unLoc lVar of + Nothing -> return () + Just demoted_name -> do + let global_vars = lookupGRE gbl_env (LookupRdrName demoted_name SameNameSpace) + let mlocal_var = lookupLocalRdrEnv local_env demoted_name + case mlocal_var of + Just name -> warnCapturedTerm lVar (Right name) + Nothing -> unless (null global_vars) $ + warnCapturedTerm lVar (Left global_vars) + bindHsForAllTelescope :: HsDocContext -> HsForAllTelescope GhcPs -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars)) @@ -1218,7 +1185,7 @@ -> RnM (b, FreeVars) bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; checkDupRdrNamesN tv_names_w_loc + ; checkDupRdrNames tv_names_w_loc ; go tv_bndrs thing_inside } where tv_names_w_loc = map hsLTyVarLocName tv_bndrs @@ -1256,15 +1223,87 @@ $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -newTyVarNameRn :: Maybe a -- associated class - -> LocatedN RdrName -> RnM Name -newTyVarNameRn mb_assoc lrdr@(L _ rdr) +-- Check for TypeAbstractions and update the type parameter of HsBndrVis. +-- The binder itself is already renamed and is returned unmodified. +rnLHsTyVarBndrVisFlag + :: LHsTyVarBndr (HsBndrVis GhcPs) GhcRn + -> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) +rnLHsTyVarBndrVisFlag (L loc bndr) = do + let lbndr = L loc (updateHsTyVarBndrFlag rnHsBndrVis bndr) + unlessXOptM LangExt.TypeAbstractions $ + when (isHsBndrInvisible (hsTyVarBndrFlag bndr)) $ + addErr (TcRnIllegalInvisTyVarBndr lbndr) + return lbndr + +-- rnHsBndrVis is a no-op. We could use 'coerce' in an ideal world, +-- but GHC can't crack this nut because type families are involved: +-- HsBndrInvisible stores (LHsToken "@" pass), which is defined via XRec. +rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn +rnHsBndrVis HsBndrRequired = HsBndrRequired +rnHsBndrVis (HsBndrInvisible at) = HsBndrInvisible at + +newTyVarNameRn, newTyVarNameRnImplicit + :: Maybe a -- associated class + -> LocatedN RdrName -> RnM Name +newTyVarNameRn mb_assoc = new_tv_name_rn mb_assoc newLocalBndrRn +newTyVarNameRnImplicit mb_assoc = new_tv_name_rn mb_assoc $ \lrdr -> + do { warn_term_var_capture lrdr + ; newLocalBndrRn lrdr } + +new_tv_name_rn :: Maybe a -- associated class + -> (LocatedN RdrName -> RnM Name) -- how to create a new name + -> (LocatedN RdrName -> RnM Name) +new_tv_name_rn Nothing cont lrdr = cont lrdr +new_tv_name_rn (Just _) cont lrdr@(L _ rdr) = do { rdr_env <- getLocalRdrEnv - ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of - (Just _, Just n) -> return n - -- Use the same Name as the parent class decl + ; case lookupLocalRdrEnv rdr_env rdr of + Just n -> return n -- Use the same Name as the parent class decl + _ -> cont lrdr } - _ -> newLocalBndrRn lrdr } +{- Note [Term variable capture and implicit quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Wterm-variable-capture is a warning introduced in GHC Proposal #281 "Visible forall in types of terms", +Section 7.3: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-visible-forall.rst#73implicit-quantification + +Its purpose is to notify users when implicit quantification occurs that would +stop working under RequiredTypeArguments (a future GHC extension). Example: + + a = 42 + id :: a -> a + +As it stands, the `a` in the signature `id :: a -> a` is considered free and +leads to implicit quantification, as if the user wrote `id :: forall a. a -> a`. +Under RequiredTypeArguments it will capture the term-level variable `a` (bound by `a = 42`), +leading to a type error. + +`warn_term_var_capture` detects this by demoting the namespace of the +implicitly quantified type variable (`TvName` becomes `VarName`) and looking it up +in the environment. But when do we call `warn_term_var_capture`? It's tempting +to do so at the start of `rnImplicitTvOccs`, as soon as we know our implicit +variables: + + rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside + = do { let implicit_vs = nubN implicit_vs_with_dups + ; mapM_ warn_term_var_capture implicit_vs + ... } + +This approach generates false positives (#23434) because it misses a corner +case: class variables in associated types. Consider the following example: + + k = 12 + class C k a where + type AT a :: k -> Type + +If we look at the signature for `AT` in isolation, the `k` looks like a free +variable, so it's passed to `rnImplicitTvOccs`. And if we passed it to +`warn_term_var_capture`, we would find the `k` bound by `k = 12` and report a warning. +But we don't want that: `k` is actually bound in the declaration header of the +parent class. + +The solution is to check if it's a class variable (this is done in `new_tv_name_rn`) +before we check for term variable capture. +-} + {- ********************************************************* * * @@ -1301,10 +1340,12 @@ lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn lookupField fl_env (FieldOcc _ (L lr rdr)) = - FieldOcc (flSelector fl) (L lr rdr) + FieldOcc sel (L lr $ mkRdrUnqual $ occName sel) where lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "lookupField" $ lookupFsEnv fl_env lbl + sel = flSelector + $ expectJust "lookupField" + $ lookupFsEnv fl_env lbl {- ************************************************************************ @@ -1422,18 +1463,6 @@ ---------------------------- --- | Name of an operator in an operator application or section -data OpName = NormalOp Name -- ^ A normal identifier - | NegateOp -- ^ Prefix negation - | UnboundOp RdrName -- ^ An unbound identifier - | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence - -instance Outputable OpName where - ppr (NormalOp n) = ppr n - ppr NegateOp = ppr negateName - ppr (UnboundOp uv) = ppr uv - ppr (RecFldOp fld) = ppr fld - get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See GHC.Rename.Expr.rnUnboundVar @@ -1602,8 +1631,7 @@ (sectionPrecErr (get_op op, op_fix) (arg_op, arg_fix) section) --- | Look up the fixity for an operator name. Be careful to use --- 'lookupFieldFixityRn' for record fields (see #13132). +-- | Look up the fixity for an operator name. lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n) = lookupFixityRn n lookupFixityOp NegateOp = lookupFixityRn negateName @@ -1618,35 +1646,21 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", - ppr_opfix op2, - text "in the same infix expression"]) + = addErr $ TcRnPrecedenceParsingError op1 op2 sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", - nest 4 (sep [text "must have lower precedence than that of the operand,", - nest 2 (text "namely" <+> ppr_opfix arg_op)]), - nest 4 (text "in the section:" <+> quotes (ppr section))] + = addErr $ TcRnSectionPrecedenceError op arg_op section is_unbound :: OpName -> Bool is_unbound (NormalOp n) = isUnboundName n is_unbound UnboundOp{} = True is_unbound _ = False -ppr_opfix :: (OpName, Fixity) -> SDoc -ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) - where - pp_op | NegateOp <- op = text "prefix `-'" - | otherwise = quotes (ppr op) - {- ***************************************************** * * Errors @@ -1655,37 +1669,33 @@ unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal type signature:" <+> quotes (ppr ty)) - 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + = TcRnUnexpectedPatSigType ty badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) = setSrcSpanA loc $ addErr $ TcRnWithHsDocContext doc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal kind signature:" <+> quotes (ppr ty)) - 2 (text "Perhaps you intended to use KindSignatures") + TcRnKindSignaturesDisabled (Left ty) dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage dataKindsErr env thing - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use DataKinds") + = TcRnDataKindsError type_or_Kind thing where - pp_what | isRnKindLevel env = text "kind" - | otherwise = text "type" + type_or_Kind | isRnKindLevel env = KindLevel + | otherwise = TypeLevel warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names = unless (hsTyVarName tv `elemNameSet` used_names) $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) - , inHsDocContext doc ] + let msg = TcRnUnusedQuantifiedTypeVar doc (HsTyVarBndrExistentialFlag tv) addDiagnosticAt (locA loc) msg +warnCapturedTerm :: LocatedN RdrName -> Either [GlobalRdrElt] Name -> TcM () +warnCapturedTerm (L loc tv) shadowed_term_names + = let msg = TcRnCapturedTermName tv shadowed_term_names + in addDiagnosticAt (locA loc) msg + {- ************************************************************************ * * @@ -1789,15 +1799,17 @@ a free variable 'a', which we implicitly quantify over. That is why we can also use it to the left of the double colon: 'Left a -The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type -synonyms and type family instances. +The logic resides in extractHsTyRdrTyVarsKindVars. -This is something of a stopgap solution until we can explicitly bind invisible +This was a stopgap solution until we could explicitly bind invisible type/kind variables: type TySyn3 :: forall a. Maybe a type TySyn3 @a = 'Just ('Nothing :: Maybe a) +Now that the new syntax was proposed in #425 and implemented in 9.8, we issue a warning +-Wimplicit-rhs-quantification for TySyn2 and TySyn4 and will eventually disallow them. + Note [Implicit quantification in type synonyms: non-taken alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1961,7 +1973,7 @@ flds HsAppTy _ ty1 ty2 -> extract_lty ty1 $ extract_lty ty2 acc - HsAppKindTy _ ty k -> extract_lty ty $ + HsAppKindTy _ ty _ k -> extract_lty ty $ extract_lty k acc HsListTy _ ty -> extract_lty ty acc HsTupleTy _ _ tys -> extract_ltys tys acc @@ -1980,8 +1992,7 @@ HsExplicitTupleTy _ tys -> extract_ltys tys acc HsTyLit _ _ -> acc HsStarTy _ _ -> acc - HsKindSig _ ty ki -> extract_lty ty $ - extract_lty ki acc + HsKindSig _ ty ki -> extract_kind_sig ty ki acc HsForAllTy { hst_tele = tele, hst_body = ty } -> extract_hs_for_all_telescope tele acc $ extract_lty ty [] @@ -1992,6 +2003,19 @@ -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc +extract_kind_sig :: LHsType GhcPs -- type + -> LHsType GhcPs -- kind + -> FreeKiTyVars -> FreeKiTyVars +extract_kind_sig ty ki acc + | (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = ki_body }) <- ki + = extract_hs_tv_bndrs bndrs acc $ + extract_lty ty $ + extract_lty ki_body [] +extract_kind_sig ty ki acc + = extract_lty ty $ + extract_lty ki acc + extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = extractHsOuterTvBndrs outer_bndrs $ extract_lty body [] @@ -2051,7 +2075,7 @@ extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc = - if isRdrTyVar (unLoc tv) then tv:acc else acc + if isRdrTyVar (unLoc tv) && (not . isQual) (unLoc tv) then tv:acc else acc -- Deletes duplicates in a list of Located things. This is used to: -- 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -21,7 +22,6 @@ import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs -import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType @@ -29,7 +29,7 @@ import GHC.Rename.Doc import GHC.Rename.Env import GHC.Rename.Utils ( mapFvRn, bindLocalNames - , checkDupRdrNamesN, bindLocalNamesFV + , checkDupRdrNames, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns , newLocalBndrsRn , noNestedForallsContextsErr @@ -37,9 +37,9 @@ import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr (pprScopeError) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin ( TypedThing(..) ) import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Unit @@ -52,17 +52,16 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.Avail import GHC.Utils.Outputable import GHC.Data.Bag -import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Misc ( lengthExceeds, partitionWith ) import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) -import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) +import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) import GHC.Types.Unique.Set @@ -74,11 +73,10 @@ import Control.Arrow ( first ) import Data.Foldable ( toList ) import Data.List ( mapAccumL ) -import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..), head ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) -import Data.Function ( on ) +import GHC.Types.GREInfo (ConInfo, mkConInfo, conInfoFields) {- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing. @@ -155,7 +153,7 @@ -- Excludes pattern-synonym binders -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; - tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; + tc_envs <- extendGlobalRdrEnvRn (map (mkLocalVanillaGRE NoParent) id_bndrs) local_fix_env ; restoreEnvs tc_envs $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -189,13 +187,15 @@ -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; + traceRn "rnSrcDecls fixity" $ + vcat [ text "all_bndrs:" <+> ppr all_bndrs ] ; rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) fix_decls ; -- Rename deprec decls; -- check for duplicates and ensure that deprecated things are defined locally -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; + rn_decl_warns <- rnSrcWarnDecls all_bndrs warn_decls ; -- (H) Rename Everything else @@ -237,7 +237,7 @@ final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) in -- we return the deprecs in the env, not in the HsGroup above - tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + tcg_env' { tcg_warns = insertWarnDecls (tcg_warns tcg_env') rn_decl_warns }; } ; traceRn "finish rnSrc" (ppr rn_group) ; traceRn "finish Dus" (ppr src_dus ) ; @@ -267,9 +267,9 @@ -} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (DeclWarnOccNames GhcRn) rnSrcWarnDecls _ [] - = return NoWarnings + = return [] rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates @@ -277,7 +277,7 @@ in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocMA rn_deprec) decls - ; return (WarnSome ((concat pairs_s))) } + ; return $ concat pairs_s } where decls = concatMap (wd_warnings . unLoc) decls' @@ -288,7 +288,10 @@ = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) rdr_names ; txt' <- rnWarningTxt txt - ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] } + ; return [(nameOccName nm, txt') | (_, nm) <- names] } + -- Use the OccName from the Name we looked up, rather than from the RdrName, + -- as we might hit multiple different NameSpaces when looking up + -- (e.g. deprecating both a variable and a record field). what = text "deprecation" @@ -296,9 +299,12 @@ $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) -rnWarningTxt (WarningTxt st wst) = do +rnWarningTxt (WarningTxt mb_cat st wst) = do + forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) -> + unless (validWarningCategory cat) $ + addErrAt loc (TcRnInvalidWarningCategory cat) wst' <- traverse (traverse rnHsDoc) wst - pure (WarningTxt st wst') + pure (WarningTxt mb_cat st wst') rnWarningTxt (DeprecatedTxt st wst) = do wst' <- traverse (traverse rnHsDoc) wst pure (DeprecatedTxt st wst') @@ -449,11 +455,9 @@ checkCanonicalInstances cls poly_ty mbinds = do whenWOptM Opt_WarnNonCanonicalMonadInstances $ checkCanonicalMonadInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" whenWOptM Opt_WarnNonCanonicalMonoidInstances $ checkCanonicalMonoidInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" where -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance @@ -469,19 +473,17 @@ -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). -- - checkCanonicalMonadInstances refURL + checkCanonicalMonadInstances | cls == applicativeClassName = forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "pure" "return" + -> addWarnNonCanonicalMonad NonCanonical_Pure | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" + -> addWarnNonCanonicalMonad NonCanonical_ThenA _ -> return () @@ -491,12 +493,10 @@ FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "return" "pure" + -> addWarnNonCanonicalMonad NonCanonical_Return | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" + -> addWarnNonCanonicalMonad NonCanonical_ThenM _ -> return () @@ -515,15 +515,14 @@ -- -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). -- - checkCanonicalMonoidInstances refURL + checkCanonicalMonoidInstances | cls == semigroupClassName = forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" + -> addWarnNonCanonicalMonoid NonCanonical_Sappend _ -> return () @@ -533,9 +532,7 @@ FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonoidInstances - "mappend" "(<>)" + -> addWarnNonCanonicalMonoid NonCanonical_Mappend _ -> return () @@ -551,58 +548,21 @@ , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , quotes (text lhs) <+> - text "will eventually be removed in favour of" <+> - quotes (text rhs) - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "(recommended)" <+> - text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- stolen from GHC.Tc.TyCl.Instance - instDeclCtxt1 :: LHsSigType GhcRn -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + addWarnNonCanonicalMonoid reason = + addWarnNonCanonicalDefinition (NonCanonicalMonoid reason) - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") + addWarnNonCanonicalMonad reason = + addWarnNonCanonicalDefinition (NonCanonicalMonad reason) + addWarnNonCanonicalDefinition reason = + addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty) rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = oflag , cid_datafam_insts = adts }) - = do { checkInferredVars ctxt inf_err inst_ty + = do { checkInferredVars ctxt inst_ty ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' -- Check if there are any nested `forall`s or contexts, which are @@ -610,22 +570,18 @@ -- Note [No nested foralls or contexts in instance types] in -- GHC.Hs.Type)... mb_nested_msg = noNestedForallsContextsErr - (text "Instance head") head_ty' + NFC_InstanceHead head_ty' -- ...then check if the instance head is actually headed by a -- class type constructor... eith_cls = case hsTyGetAppHead_maybe head_ty' of Just (L _ cls) -> Right cls - Nothing -> Left - ( getLocA head_ty' - , mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal head of an instance declaration:" - <+> quotes (ppr head_ty')) - 2 (vcat [ text "Instance heads must be of the form" - , nest 2 $ text "C ty_1 ... ty_n" - , text "where" <+> quotes (char 'C') - <+> text "is a class" - ]) - ) + Nothing -> + Left + ( getLocA head_ty' + , TcRnIllegalInstance $ + IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $ + IllegalInstanceHead $ InstHeadNonClass Nothing + ) -- ...finally, attempt to retrieve the class type constructor, failing -- with an error message if there isn't one. To avoid excessive -- amounts of error messages, we will only report one of the errors @@ -673,7 +629,6 @@ -- to remove the context). where ctxt = GenericCtx $ text "an instance declaration" - inf_err = Just (text "Inferred type variables are not allowed") -- The instance is malformed. We'd still like to make *some* progress -- (rather than failing outright), so we report an error and continue for @@ -686,14 +641,10 @@ rnFamEqn :: HsDocContext -> AssocTyFamInfo - -> FreeKiTyVars - -- ^ Additional kind variables to implicitly bind if there is no - -- explicit forall. (See the comments on @all_imp_vars@ below for a - -- more detailed explanation.) -> FamEqn GhcPs rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) -> RnM (FamEqn GhcRn rhs', FreeVars) -rnFamEqn doc atfi extra_kvars +rnFamEqn doc atfi (FamEqn { feqn_tycon = tycon , feqn_bndrs = outer_bndrs , feqn_pats = pats @@ -704,19 +655,8 @@ -- 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.Hs.Type), which means - -- ignoring: - -- - -- - pat_kity_vars, the free variables mentioned in the type patterns - -- on the LHS of the equation, and - -- - extra_kvars, which is one of the following: - -- * For type family instances, extra_kvars are the free 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 data family instances, extra_kvars are the free kind - -- variables mentioned in the explicit return kind, if one is - -- provided. (e.g., the `k` in `data instance T :: k -> Type`). + -- ignoring pat_kity_vars, the free variables mentioned in the type patterns + -- on the LHS of the equation -- -- Some examples: -- @@ -730,8 +670,6 @@ -- type family G :: Maybe a -- type instance forall a. G = (Nothing :: Maybe a) -- -- all_imp_vars = [] - -- type instance G = (Nothing :: Maybe a) - -- -- all_imp_vars = [a] -- -- data family H :: k -> Type -- data instance forall k. H :: k -> Type where ... @@ -742,7 +680,7 @@ -- -- For associated type family instances, exclude the type variables -- bound by the instance head with filterInScopeM (#19649). - ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars + ; all_imp_vars <- filterInScopeM $ pat_kity_vars ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs -> do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats @@ -779,24 +717,17 @@ -- associated family instance but not bound on the LHS, then reject -- that type variable as being out of scope. -- See Note [Renaming associated types]. - -- Per that Note, the LHS type variables consist of: - -- - -- - The variables mentioned in the instance's type patterns - -- (pat_fvs), and - -- - -- - The variables mentioned in an outermost kind signature on the - -- RHS. This is a subset of `rhs_fvs`. To compute it, we look up - -- each RdrName in `extra_kvars` to find its corresponding Name in - -- the LocalRdrEnv. - ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars - ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms - improperly_scoped cls_tkv = + -- Per that Note, the LHS type variables consist of the variables + -- mentioned in the instance's type patterns (pat_fvs) + ; let improperly_scoped cls_tkv = cls_tkv `elemNameSet` rhs_fvs -- Mentioned on the RHS... - && not (cls_tkv `elemNameSet` lhs_bound_vars) + && not (cls_tkv `elemNameSet` pat_fvs) -- ...but not bound on the LHS. bad_tvs = filter improperly_scoped inst_head_tvs - ; unless (null bad_tvs) (badAssocRhs bad_tvs) + ; unless (null bad_tvs) $ addErr $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamInstRHSOutOfScopeTyVars Nothing bad_tvs ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs -- See Note [Type family equations and occurrences] @@ -838,19 +769,11 @@ -- -- type instance F a b c = Either a b -- ^^^^^ - lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of + lhs_loc = case map lhsTypeArgSrcSpan pats of [] -> panic "rnFamEqn.lhs_loc" [loc] -> loc (loc:locs) -> loc `combineSrcSpans` last locs - badAssocRhs :: [Name] -> RnM () - badAssocRhs ns - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "The RHS of an associated type declaration mentions" - <+> text "out-of-scope variable" <> plural ns - <+> pprWithCommas (quotes . ppr) ns) - 2 (text "All such variables must be bound on the LHS")) - rnTyFamInstDecl :: AssocTyFamInfo -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars) @@ -905,11 +828,10 @@ rnTyFamInstEqn :: AssocTyFamInfo -> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars) -rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs }) - = rnFamEqn (TySynCtx tycon) atfi extra_kvs eqn rnTySyn - where - extra_kvs = extractHsTyRdrTyVarsKindVars rhs +rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon }) + = rnFamEqn (TySynCtx tycon) atfi eqn rnTySyn + rnTyFamDefltDecl :: Name -> TyFamDefltDecl GhcPs -> RnM (TyFamDefltDecl GhcRn, FreeVars) @@ -919,11 +841,9 @@ -> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars) rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = - eqn@(FamEqn { feqn_tycon = tycon - , feqn_rhs = rhs })}) - = do { let extra_kvs = extractDataDefnKindVars rhs - ; (eqn', fvs) <- - rnFamEqn (TyDataCtx tycon) atfi extra_kvs eqn rnDataDefn + eqn@(FamEqn { feqn_tycon = tycon })}) + = do { (eqn', fvs) <- + rnFamEqn (TyDataCtx tycon) atfi eqn rnDataDefn ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } -- Renaming of the associated types in instances. @@ -1009,10 +929,7 @@ properly scoped. Specifically, the rule is this: Every variable mentioned on the RHS of a type instance declaration - (whether associated or not) must be either - * Mentioned on the LHS, or - * Mentioned in an outermost kind signature on the RHS - (see Note [Implicit quantification in type synonyms]) + (whether associated or not) must be mentioned on the LHS Here is a simple example of something we should reject: @@ -1022,8 +939,7 @@ type F Int x = z Here, `z` is mentioned on the RHS of the associated instance without being -mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The -renamer will reject `z` as being out of scope without much fuss. +mentioned on the LHS. The renamer will reject `z` as being out of scope without much fuss. Things get slightly trickier when the instance header itself binds type variables. Consider this example (adapted from #5515): @@ -1115,10 +1031,8 @@ Note that the `o` in the `Codomain 'KProxy` instance should be considered improperly scoped. It does not meet the criteria for being explicitly - quantified, as it is not mentioned by name on the LHS, nor does it meet the - criteria for being implicitly quantified, as it is used in a RHS kind - signature that is not outermost (see Note [Implicit quantification in type - synonyms]). However, `o` /is/ bound by the instance header, so if this + quantified, as it is not mentioned by name on the LHS. + However, `o` /is/ bound by the instance header, so if this program is not rejected by the renamer, the typechecker would treat it as though you had written this: @@ -1130,6 +1044,12 @@ If the user really wants the latter, it is simple enough to communicate their intent by mentioning `o` on the LHS by name. +* Historical note: Previously we had to add type variables from the outermost + kind signature on the RHS to the scope of associated type family instance, + i.e. GHC did implicit quantification over them. But now that we implement + GHC Proposal #425 "Invisible binders in type declarations" + we don't need to do this anymore. + Note [Type family equations and occurrences] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In most data/type family equations, the type family name used in the equation @@ -1188,30 +1108,23 @@ rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) rnSrcDerivDecl (DerivDecl _ ty mds overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving - ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; checkInferredVars ctxt inf_err nowc_ty + ; unless standalone_deriv_ok (addErr TcRnUnexpectedStandaloneDerivingDecl) + ; checkInferredVars ctxt nowc_ty ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty -- Check if there are any nested `forall`s or contexts, which are -- illegal in the type of an instance declaration (see -- Note [No nested foralls or contexts in instance types] in -- GHC.Hs.Type). ; addNoNestedForallsContextsErr ctxt - (text "Standalone-derived instance head") + NFC_StandaloneDerivedInstanceHead (getLHsInstDeclHead $ dropWildCards ty') ; warnNoDerivStrat mds' loc ; return (DerivDecl noAnn ty' mds' overlap, fvs) } where ctxt = DerivDeclCtx - inf_err = Just (text "Inferred type variables are not allowed") loc = getLocA nowc_ty nowc_ty = dropWildCards ty -standaloneDerivErr :: TcRnMessage -standaloneDerivErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal standalone deriving declaration") - 2 (text "Use StandaloneDeriving to enable this extension") - {- ********************************************************* * * @@ -1237,7 +1150,7 @@ , rd_rhs = rhs }) = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs ; mapM_ warnForallIdentifier rdr_names_w_loc - ; checkDupRdrNamesN rdr_names_w_loc + ; checkDupRdrNames rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc ; let doc = RuleCtx (unLoc rule_name) @@ -1314,7 +1227,7 @@ -- Check that LHS vars are all bound ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mapM_ (addErr . badRuleVar rule_name) bad_vars } + ; mapM_ (addErr . TcRnUnusedVariableInRuleDecl rule_name) bad_vars } validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) -- Nothing => OK @@ -1351,27 +1264,15 @@ checkl_es es = foldr (mplus . checkl_e) Nothing es -} -badRuleVar :: FastString -> Name -> TcRnMessage -badRuleVar name var - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, - text "Forall'd variable" <+> quotes (ppr var) <+> - text "does not appear on left hand side"] badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage badRuleLhsErr name lhs bad_e - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Rule" <+> pprRuleName name <> colon, - nest 2 (vcat [err, - text "in left-hand side:" <+> ppr lhs])] - $$ - text "LHS must be of form (f e1 .. en) where f is not forall'd" + = TcRnIllegalRuleLhs errReason name lhs bad_e where - err = - case bad_e of - HsUnboundVar _ uv -> - pprScopeError uv $ notInScopeErr WL_Global uv - _ -> text "Illegal expression:" <+> ppr bad_e + errReason = case bad_e of + HsUnboundVar _ uv -> + UnboundVariable uv $ notInScopeErr WL_Global uv + _ -> IllegalExpression {- ************************************************************** * * @@ -1520,12 +1421,17 @@ = do { -- Rename the type/class, instance, and role declarations ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds) ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) + ; traceRn "rnTyClDecls" $ + vcat [ text "tyClGroupTyClDecls:" <+> ppr tycls_w_fvs + , text "tc_names:" <+> ppr tc_names ] ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) -- Do SCC analysis on the type/class decls ; rdr_env <- getGlobalRdrEnv + ; traceRn "rnTyClDecls SCC analysis" $ + vcat [ text "rdr_env:" <+> ppr rdr_env ] ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs role_annot_env = mkRoleAnnotEnv role_annots (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs @@ -1604,7 +1510,7 @@ -> [LStandaloneKindSig GhcPs] -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] rnStandaloneKindSignatures tc_names kisigs - = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs + = do { let (no_dups, dup_kisigs) = removeDupsOn get_name kisigs get_name = standaloneKindSigName . unLoc ; mapM_ dupKindSig_Err dup_kisigs ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups @@ -1616,17 +1522,12 @@ -> RnM (StandaloneKindSig GhcRn, FreeVars) rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures - ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr - ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v + ; unless standalone_ki_sig_ok $ addErr TcRnUnexpectedStandaloneKindSig + ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v) ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } - where - standaloneKiSigErr :: TcRnMessage - standaloneKiSigErr = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal standalone kind signature") - 2 (text "Did you mean to enable StandaloneKindSignatures?") depAnalTyClDecls :: GlobalRdrEnv -> KindSig_FV_Env @@ -1660,7 +1561,7 @@ getParent :: GlobalRdrEnv -> Name -> Name getParent rdr_env n = case lookupGRE_Name rdr_env n of - Just gre -> case gre_par gre of + Just gre -> case greParent gre of ParentIs { par_is = p } -> p _ -> n Nothing -> n @@ -1682,7 +1583,7 @@ rnRoleAnnots tc_names role_annots = do { -- Check for duplicates *before* renaming, to avoid -- lumping together all the unboundNames - let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots + let (no_dups, dup_annots) = removeDupsOn get_name role_annots get_name = roleAnnotDeclName . unLoc ; mapM_ dupRoleAnnotErr dup_annots ; mapM (wrapLocMA rn_role_annot1) no_dups } @@ -1690,40 +1591,18 @@ rn_role_annot1 (RoleAnnotDecl _ tycon roles) = do { -- the name is an *occurrence*, but look it up only in the -- decls defined in this group (see #10263) - tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon + tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) + (text "role annotation") + tycon ; return $ RoleAnnotDecl noExtField tycon' roles } dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () -dupRoleAnnotErr list - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Duplicate role annotations for" <+> - quotes (ppr $ roleAnnotDeclName first_decl) <> colon) - 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((L loc first_decl) :| _) = sorted_list - - pp_role_annot (L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLocA +dupRoleAnnotErr list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateRoleAnnot list) dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () -dupKindSig_Err list - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Duplicate standalone kind signatures for" <+> - quotes (ppr $ standaloneKindSigName first_decl) <> colon) - 2 (vcat $ map pp_kisig $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((L loc first_decl) :| _) = sorted_list - - pp_kisig (L loc decl) = - hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLocA +dupKindSig_Err list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateKindSig list) {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1810,11 +1689,16 @@ ; let kvs = extractHsTyRdrTyVarsKindVars rhs doc = TySynCtx tycon ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ -> - do { (rhs', fvs) <- rnTySyn doc rhs + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' free_rhs_kvs -> + do { mapM_ warn_implicit_kvs (nubL free_rhs_kvs) + ; (rhs', fvs) <- rnTySyn doc rhs ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdFixity = fixity , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } + where + warn_implicit_kvs :: LocatedN RdrName -> RnM () + warn_implicit_kvs kv = + addDiagnosticAt (getLocA kv) (TcRnImplicitRhsQuantification kv) -- "data", "newtype" declarations rnTyClDecl (DataDecl @@ -1826,12 +1710,12 @@ doc = TyDataCtx tycon new_or_data = dataDefnConsNewOrData cons ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' free_rhs_kvs -> do { (defn', fvs) <- rnDataDefn doc defn - ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig + ; cusk <- data_decl_has_cusk tyvars' new_or_data (null free_rhs_kvs) kind_sig ; let rn_info = DataDeclRn { tcdDataCusk = cusk , tcdFVs = fvs } - ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr free_rhs_kvs) ; return (DataDecl { tcdLName = tycon' , tcdTyVars = tyvars' , tcdFixity = fixity @@ -1871,7 +1755,7 @@ ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] - ; checkDupRdrNamesN sig_rdr_names_w_locs + ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't @@ -1953,7 +1837,7 @@ = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon. checkTc (h98_style || null (fromMaybeContext context)) - (badGadtStupidTheta doc) + (TcRnStupidThetaInGadt doc) -- Check restrictions on "type data" declarations. -- See Note [Type data declarations]. @@ -1989,7 +1873,7 @@ rn_derivs ds = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) - multipleDerivClausesErr + TcRnIllegalMultipleDerivClauses ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds ; return (ds', fvs) } @@ -2067,14 +1951,7 @@ (R3) There are no strictness flags, because they don't make sense at the type level. -(R4) The types of the constructors contain no constraints other than - equality constraints. (This is the same restriction imposed - on constructors to be promoted with the DataKinds extension in - dc_theta_illegal_constraint called from GHC.Tc.Gen.HsType.tcTyVar, - but in that case the restriction is imposed if and when a data - constructor is used in a type, whereas here it is imposed at - the point of definition. See also Note [Constraints in kinds] - in GHC.Core.TyCo.Rep.) +(R4) The types of the constructors contain no constraints. (R5) There are no deriving clauses. @@ -2092,8 +1969,6 @@ is never used (invariant (I1)), so it barely makes sense to talk about the worker. A `type data` constructor only shows up in types, where it appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. - See #24620 for an example of what happens if you accidentally include - a wrapper. See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where this check is implemented. @@ -2142,20 +2017,17 @@ with the data constructor, else (I1) is violated. See GHC.Core.Utils Note [Refine DEFAULT case alternatives] Exception 2 - (W2c) In `GHC.Core.Opt.ConstantFold.caseRules`, we do not want to transform - case dataToTagLarge# x of t -> blah + (W2c) In `GHC.Core.Opt.ConstantFold.caseRules`, disable the rule for + `dataToTag#` in the case of `type data`. We do not want to transform + case dataToTag# x of t -> blah into case x of { A -> ...; B -> .. } - because again that conjures up the type-level-only data constructors + because again that conjures up the type-level-only data contructors `A` and `B` in a pattern, violating (I1) (#23023). - So we check for "type data" TyCons before applying this - transformation. (In practice, this doesn't matter because - we also refuse to solve DataToTag instances at types - corresponding to type data declarations. The main parts of the implementation are: -* (R0): The parser recognizes `type data` (but not `type newtype`). +* The parser recognizes `type data` (but not `type newtype`); this ensures (R0). * During the initial construction of the AST, GHC.Parser.PostProcess.checkNewOrData sets the `Bool` argument of the @@ -2214,54 +2086,6 @@ `type data` declarations. When these are converted back to Hs types in a splice, the constructors are placed in the TcCls namespace. -* A `type data` declaration _never_ generates wrappers for its data - constructors, as they only make sense for value-level data constructors. - See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where - this check is implemented. - - This includes `type data` declarations implemented as GADTs, such as - this example from #22948: - - type data T a where - A :: T Int - B :: T a - - If `T` were an ordinary `data` declaration, then `A` would have a wrapper - to account for the GADT-like equality in its return type. Because `T` is - declared as a `type data` declaration, however, the wrapper is omitted. - -* Although `type data` data constructors do not exist at the value level, - it is still possible to match on a value whose type is headed by a `type data` - type constructor, such as this example from #22964: - - type data T a where - A :: T Int - B :: T a - - f :: T a -> () - f x = case x of {} - - This has two consequences: - - * During checking the coverage of `f`'s pattern matches, we treat `T` as if it - were an empty data type so that GHC does not warn the user to match against - `A` or `B`. (Otherwise, you end up with the bug reported in #22964.) - See GHC.HsToCore.Pmc.Solver.vanillaCompleteMatchTC. - - * In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case with - the data constructor. See - Note [Refine DEFAULT case alternatives] Exception 2, in GHC.Core.Utils. - -* To prevent users from conjuring up `type data` values at the term level, we - disallow using the tagToEnum# function on a type headed by a `type data` - type. For instance, GHC will reject this code: - - type data Letter = A | B | C - - f :: Letter - f = tagToEnum# 0# - - See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. -} warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) @@ -2271,21 +2095,10 @@ = do { dyn_flags <- getDynFlags ; case mds of Nothing -> - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $ - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) - in addDiagnosticAt loc dia + addDiagnosticAt loc $ TcRnNoDerivStratSpecified + (xopt LangExt.DerivingStrategies dyn_flags) _ -> pure () } - where - no_strat_warning :: SDoc - no_strat_warning = text "No deriving strategy specified. Did you want stock" - <> text ", newtype, or anyclass?" - deriv_strat_nenabled :: SDoc - deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) @@ -2314,14 +2127,13 @@ rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) rn_clause_pred pred_ty = do - let inf_err = Just (text "Inferred type variables are not allowed") - checkInferredVars doc inf_err pred_ty + checkInferredVars doc pred_ty ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty -- Check if there are any nested `forall`s, which are illegal in a -- `deriving` clause. -- See Note [No nested foralls or contexts in instance types] -- (Wrinkle: Derived instances) in GHC.Hs.Type. - addNoNestedForallsContextsErr doc (text "Derived class type") + addNoNestedForallsContextsErr doc NFC_DerivedClassType (getLHsInstDeclHead pred_ty') pure ret @@ -2349,14 +2161,14 @@ = LangExt.DerivingStrategies unlessXOptM extNeeded $ - failWith $ illegalDerivStrategyErr ds + failWith $ TcRnIllegalDerivStrategy ds case ds of StockStrategy _ -> boring_case (StockStrategy noExtField) AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField) NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField) ViaStrategy (XViaStrategyPs _ via_ty) -> - do checkInferredVars doc inf_err via_ty + do checkInferredVars doc via_ty (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty let HsSig { sig_bndrs = via_outer_bndrs , sig_body = via_body } = unLoc via_ty' @@ -2366,43 +2178,15 @@ -- See Note [No nested foralls or contexts in instance types] -- (Wrinkle: Derived instances) in GHC.Hs.Type. addNoNestedForallsContextsErr doc - (quotes (text "via") <+> text "type") via_body + NFC_ViaType via_body (thing, fvs2) <- bindLocalNamesFV 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 pure (ds, thing, fvs) -badGadtStupidTheta :: HsDocContext -> TcRnMessage -badGadtStupidTheta _ - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "No context is allowed on a GADT-style data declaration", - text "(You can put a context on each constructor, though.)"] - -illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage -illegalDerivStrategyErr ds - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds - , text enableStrategy ] - - where - enableStrategy :: String - enableStrategy - | ViaStrategy{} <- ds - = "Use DerivingVia to enable this extension" - | otherwise - = "Use DerivingStrategies to enable this extension" - -multipleDerivClausesErr :: TcRnMessage -multipleDerivClausesErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal use of multiple, consecutive deriving clauses" - , text "Use DerivingStrategies to allow this" ] - rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested -- inside an *class decl* for cls -- used for associated types @@ -2465,11 +2249,8 @@ rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLocA tvbndr) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable") + addErrAt (getLocA tvbndr) $ + TcRnShadowedTyVarNameInFamResult resName ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for -- scoping checks that are irrelevant here @@ -2539,20 +2320,13 @@ -- not-in-scope variables) don't check the validity of injectivity -- annotation. This gives better error messages. ; when (noRnErrors && not lhsValid) $ - addErrAt (getLocA injFrom) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ( vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])]) + addErrAt (getLocA injFrom) $ + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid - ; addErrAt (locA srcSpan) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ( hsep - [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] ) } + ; addErrAt (locA srcSpan) $ + TcRnUnknownTyVarsOnRhsOfInjCond errorVars } ; return injDecl' } @@ -2660,7 +2434,7 @@ -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) -- in GHC.Hs.Type. ; addNoNestedForallsContextsErr ctxt - (text "GADT constructor type signature") new_res_ty + NFC_GadtConSig new_res_ty ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 @@ -2728,35 +2502,40 @@ -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls - ; let pat_syn_bndrs = concat [ name: map flSelector fields - | (name, fields) <- names_with_fls ] - ; let avails = map avail (map fst names_with_fls) - ++ map availField (concatMap snd names_with_fls) - ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env - - ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls - final_gbl_env = gbl_env { tcg_field_env = field_env' } - ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + ; let pat_syn_bndrs = concat [ conLikeName_Name name : map flSelector flds + | (name, con_info) <- names_with_fls + , let flds = conInfoFields con_info ] + ; let gres = map (mkLocalConLikeGRE NoParent) names_with_fls + ++ mkLocalFieldGREs NoParent names_with_fls + -- Recall Note [Parents] in GHC.Types.Name.Reader: + -- + -- pattern synonym constructors and their record fields have no parent + -- in the module in which they are defined. + ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn gres local_fix_env + ; restoreEnvs (gbl_env, lcl_env) (thing pat_syn_bndrs) } where - new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] + + new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs - -> [(Name, [FieldLabel])] - -> TcM [(Name, [FieldLabel])] + -> [(ConLikeName, ConInfo)] + -> TcM [(ConLikeName, ConInfo)] new_ps' bind names | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n , psb_args = RecCon as }))) <- bind = do bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as - flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs - return ((bnd_name, flds): names) - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind + flds <- mapM (newRecordFieldLabel dup_fields_ok has_sel [bnd_name]) field_occs + let con_info = mkConInfo (conDetailsArity length (RecCon as)) flds + return ((PatSynName bnd_name, con_info) : names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind = do bnd_name <- newTopSrcBinder (L (la2na bind_loc) n) - return ((bnd_name, []): names) + let con_info = mkConInfo (conDetailsArity length as) [] + return ((PatSynName bnd_name, con_info) : names) | otherwise = return names @@ -2822,23 +2601,18 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds = do { -- We've found a top-level splice. If it is an *implicit* one - -- (i.e. a naked top level expression) + -- (i.e. a naked top level expression), throw an error if + -- TemplateHaskell is not enabled. case flag of DollarSplice -> return () - BareSplice -> do { th_on <- xoptM LangExt.TemplateHaskell - ; unless th_on $ setSrcSpan (locA loc) $ - failWith badImplicitSplice } + BareSplice -> do { unlessXOptM LangExt.TemplateHaskell + $ setSrcSpan (locA loc) + $ failWith badImplicitSplice } ; return (gp, Just (splice, ds)) } where badImplicitSplice :: TcRnMessage - badImplicitSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Parse error: module header, import declaration" - $$ text "or top-level declaration expected." - -- The compiler should suggest the above, and not using - -- TemplateHaskell since the former suggestion is more - -- relevant to the larger base of users. - -- See #12146 for discussion. + badImplicitSplice = TcRnTHError (THSyntaxError BadImplicitSplice) -- Class declarations: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds 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 @@ -8,2201 +8,2237 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} - -module GHC.Rename.Names ( - rnImports, getLocalNonValBinders, newRecordSelector, - extendGlobalRdrEnvRn, - gresFromAvails, - calculateAvails, - reportUnusedNames, - checkConName, - mkChildEnv, - findChildren, - findImportUsage, - getMinimalImports, - printMinimalImports, - renamePkgQual, renameRawPkgQual, - ImportDeclUsage - ) where - -import GHC.Prelude hiding ( head, init, last, tail ) - -import GHC.Driver.Env -import GHC.Driver.Session -import GHC.Driver.Ppr - -import GHC.Rename.Env -import GHC.Rename.Fixity -import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) - -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad - -import GHC.Hs -import GHC.Iface.Load ( loadSrcInterface ) -import GHC.Builtin.Names -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Core.Type -import GHC.Core.PatSyn -import GHC.Core.TyCon ( TyCon, tyConName ) -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Misc as Utils -import GHC.Utils.Panic - -import GHC.Types.Fixity.Env -import GHC.Types.SafeHaskell -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Types.Avail -import GHC.Types.FieldLabel -import GHC.Types.SourceFile -import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TopLevelFlag(..) ) -import GHC.Types.SourceText -import GHC.Types.Id -import GHC.Types.HpcInfo -import GHC.Types.Error -import GHC.Types.PkgQual - -import GHC.Unit -import GHC.Unit.Module.Warnings -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Imported -import GHC.Unit.Module.Deps -import GHC.Unit.Env - -import GHC.Data.Maybe -import GHC.Data.FastString -import GHC.Data.FastString.Env - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Control.Monad -import Data.Either ( partitionEithers ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Ord ( comparing ) -import Data.List ( partition, (\\), find, sortBy ) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Function ( on ) -import qualified Data.Set as S -import Data.Foldable ( toList ) -import System.FilePath (()) - -import System.IO -import GHC.Data.Bag - -{- -************************************************************************ -* * -\subsection{rnImports} -* * -************************************************************************ - -Note [Tracking Trust Transitively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we import a package as well as checking that the direct imports are safe -according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main -we must also check that these rules hold transitively for all dependent modules -and packages. Doing this without caching any trust information would be very -slow as we would need to touch all packages and interface files a module depends -on. To avoid this we make use of the property that if a modules Safe Haskell -mode changes, this triggers a recompilation from that module in the dependency -graph. So we can just worry mostly about direct imports. - -There is one trust property that can change for a package though without -recompilation being triggered: package trust. So we must check that all -packages a module transitively depends on to be trusted are still trusted when -we are compiling this module (as due to recompilation avoidance some modules -below may not be considered trusted any more without recompilation being -triggered). - -We handle this by augmenting the existing transitive list of packages a module M -depends on with a bool for each package that says if it must be trusted when the -module M is being checked for trust. This list of trust required packages for a -single import is gathered in the rnImportDecl function and stored in an -ImportAvails data structure. The union of these trust required packages for all -imports is done by the rnImports function using the combine function which calls -the plusImportAvails function that is a union operation for the ImportAvails -type. This gives us in an ImportAvails structure all packages required to be -trusted for the module we are currently compiling. Checking that these packages -are still trusted (and that direct imports are trusted) is done in -GHC.Driver.Main.checkSafeImports. - -See the note below, [Trust Own Package] for a corner case in this method and -how its handled. - - -Note [Trust Own Package] -~~~~~~~~~~~~~~~~~~~~~~~~ -There is a corner case of package trust checking that the usual transitive check -doesn't cover. (For how the usual check operates see the Note [Tracking Trust -Transitively] below). The case is when you import a -XSafe module M and M -imports a -XTrustworthy module N. If N resides in a different package than M, -then the usual check works as M will record a package dependency on N's package -and mark it as required to be trusted. If N resides in the same package as M -though, then importing M should require its own package be trusted due to N -(since M is -XSafe so doesn't create this requirement by itself). The usual -check fails as a module doesn't record a package dependency of its own package. -So instead we now have a bool field in a modules interface file that simply -states if the module requires its own package to be trusted. This field avoids -us having to load all interface files that the module depends on to see if one -is trustworthy. - - -Note [Trust Transitive Property] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -So there is an interesting design question in regards to transitive trust -checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch -of modules and packages, some packages it requires to be trusted as its using --XTrustworthy modules from them. Now if I have a module A that doesn't use safe -haskell at all and simply imports B, should A inherit all the trust -requirements from B? Should A now also require that a package p is trusted since -B required it? - -We currently say no but saying yes also makes sense. The difference is, if a -module M that doesn't use Safe Haskell imports a module N that does, should all -the trusted package requirements be dropped since M didn't declare that it cares -about Safe Haskell (so -XSafe is more strongly associated with the module doing -the importing) or should it be done still since the author of the module N that -uses Safe Haskell said they cared (so -XSafe is more strongly associated with -the module that was compiled that used it). - -Going with yes is a simpler semantics we think and harder for the user to stuff -up but it does mean that Safe Haskell will affect users who don't care about -Safe Haskell as they might grab a package from Cabal which uses safe haskell (say -network) and that packages imports -XTrustworthy modules from another package -(say bytestring), so requires that package is trusted. The user may now get -compilation errors in code that doesn't do anything with Safe Haskell simply -because they are using the network package. They will have to call 'ghc-pkg -trust network' to get everything working. Due to this invasive nature of going -with yes we have gone with no for now. --} - --- | Process Import Decls. See 'rnImportDecl' for a description of what --- the return types represent. --- Note: Do the non SOURCE ones first, so that we get a helpful warning --- for SOURCE ones that are unnecessary -rnImports :: [(LImportDecl GhcPs, SDoc)] - -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImports imports = do - tcg_env <- getGblEnv - -- NB: want an identity module here, because it's OK for a signature - -- module to import from its implementor - let this_mod = tcg_mod tcg_env - let (source, ordinary) = partition (is_source_import . fst) imports - is_source_import d = ideclSource (unLoc d) == IsBoot - stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary - stuff2 <- mapAndReportM (rnImportDecl this_mod) source - -- Safe Haskell: See Note [Tracking Trust Transitively] - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) - -- Update imp_boot_mods if imp_direct_mods mentions any of them - let merged_import_avail = clobberSourceImports imp_avails - dflags <- getDynFlags - let final_import_avail = - merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) - `S.union` imp_dep_direct_pkgs merged_import_avail} - return (decls, rdr_env, final_import_avail, hpc_usage) - - where - clobberSourceImports imp_avails = - imp_avails { imp_boot_mods = imp_boot_mods' } - where - imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv) - (imp_boot_mods imp_avails) - (imp_direct_dep_mods imp_avails) - - combJ (GWIB _ IsBoot) x = Just x - combJ r _ = Just r - -- See Note [Combining ImportAvails] - combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) - combine ss = - let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr - plus - ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) - ss - in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, - hpc_usage) - - plus (decl, gbl_env1, imp_avails1, hpc_usage1) - (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) - = ( decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1' `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2, - extendModuleSetList finsts_set new_finsts ) - where - imp_avails1' = imp_avails1 { imp_finsts = [] } - new_finsts = imp_finsts imp_avails1 - -{- -Note [Combining ImportAvails] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -imp_finsts in ImportAvails is a list of family instance modules -transitively depended on by an import. imp_finsts for a currently -compiled module is a union of all the imp_finsts of imports. -Computing the union of two lists of size N is O(N^2) and if we -do it to M imports we end up with O(M*N^2). That can get very -expensive for bigger module hierarchies. - -Union can be optimized to O(N log N) if we use a Set. -imp_finsts is converted back and forth between dep_finsts, so -changing a type of imp_finsts means either paying for the conversions -or changing the type of dep_finsts as well. - -I've measured that the conversions would cost 20% of allocations on my -test case, so that can be ruled out. - -Changing the type of dep_finsts forces checkFamInsts to -get the module lists in non-deterministic order. If we wanted to restore -the deterministic order, we'd have to sort there, which is an additional -cost. As far as I can tell, using a non-deterministic order is fine there, -but that's a brittle nonlocal property which I'd like to avoid. - -Additionally, dep_finsts is read from an interface file, so its "natural" -type is a list. Which makes it a natural type for imp_finsts. - -Since rnImports.combine is really the only place that would benefit from -it being a Set, it makes sense to optimize the hot loop in rnImports.combine -without changing the representation. - -So here's what we do: instead of naively merging ImportAvails with -plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts -and compute the union on the side using Sets. When we're done, we can -convert it back to a list. One nice side effect of this approach is that -if there's a lot of overlap in the imp_finsts of imports, the -Set doesn't really need to grow and we don't need to allocate. - -Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in -23s before, and 11s after. --} - - - --- | Given a located import declaration @decl@ from @this_mod@, --- calculate the following pieces of information: --- --- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in --- the entity lists have been resolved into 'Name's, --- --- 2. A 'GlobalRdrEnv' representing the new identifiers that were --- brought into scope (taking into account module qualification --- and hiding), --- --- 3. 'ImportAvails' summarizing the identifiers that were imported --- by this declaration, and --- --- 4. A boolean 'AnyHpcUsage' which is true if the imported module --- used HPC. -rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc) - -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImportDecl this_mod - (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name - , ideclPkgQual = raw_pkg_qual - , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_style - , ideclExt = XImportDeclPass { ideclImplicit = implicit } - , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) - = setSrcSpanA loc $ do - - case raw_pkg_qual of - NoRawPkgQual -> pure () - RawPkgQual _ -> do - pkg_imports <- xoptM LangExt.PackageImports - when (not pkg_imports) $ addErr packageImportErr - - let qual_only = isImportDeclQualified qual_style - - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - let imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> import_reason - - hsc_env <- getTopEnv - unit_env <- hsc_unit_env <$> getTopEnv - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual - - -- Check for self-import, which confuses the typechecker (#9032) - -- ghc --make rejects self-import cycles already, but batch-mode may not - -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid - -- typechecker crashes. (Indirect self imports are not caught until - -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) - -- - -- Originally, we also allowed 'import {-# SOURCE #-} M', but this - -- caused bug #10182: in one-shot mode, we should never load an hs-boot - -- file for the module we are compiling into the EPS. In principle, - -- it should be possible to support this mode of use, but we would have to - -- extend Provenance to support a local definition in a qualified location. - -- For now, we don't support it, but see #10336 - when (imp_mod_name == moduleName this_mod && - (case pkg_qual of -- If we have import "" M, then we should - -- check that "" is "this" (which is magic) - -- or the name of this_mod's package. Yurgh! - -- c.f. GHC.findModule, and #9997 - NoPkgQual -> True - ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) - OtherPkg _ -> False)) - (addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "A module cannot import itself:" <+> ppr imp_mod_name)) - - -- Check for a missing import list (Opt_WarnMissingImportList also - -- checks for T(..) items but that is done in checkDodgyImport below) - case imp_details of - Just (Exactly, _) -> return () -- Explicit import list - _ | implicit -> return () -- Do not bleat for implicit imports - | qual_only -> return () - | otherwise -> whenWOptM Opt_WarnMissingImportList $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList) - noHints - (missingImportListWarn imp_mod_name) - addDiagnostic msg - - - iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual - - -- Compiler sanity check: if the import didn't say - -- {-# SOURCE #-} we should not get a hi-boot file - warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do - - -- Issue a user warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports. - -- - -- in --make and GHCi, the compilation manager checks for this, - -- and indeed we shouldn't do it here because the existence of - -- the non-boot module depends on the compilation order, which - -- is not deterministic. The hs-boot test can show this up. - dflags <- getDynFlags - warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) - (warnRedundantSourceImport imp_mod_name) - when (mod_safe && not (safeImportsOn dflags)) $ - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "safe import can't be used as Safe Haskell isn't on!" - $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe")) - - let - qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = locA loc, is_as = qual_mod_name } - - -- filter the imports according to the import declaration - (new_imp_details, gres) <- filterImports iface imp_spec imp_details - - -- for certain error messages, we’d like to know what could be imported - -- here, if everything were imported - potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing - - let gbl_env = mkGlobalRdrEnv gres - - is_hiding | Just (EverythingBut,_) <- imp_details = True - | otherwise = False - - -- should the import be safe? - mod_safe' = mod_safe - || (not implicit && safeDirectImpsReq dflags) - || (implicit && safeImplicitImpsReq dflags) - - hsc_env <- getTopEnv - let home_unit = hsc_home_unit hsc_env - other_home_units = hsc_all_home_unit_ids hsc_env - imv = ImportedModsVal - { imv_name = qual_mod_name - , imv_span = locA loc - , imv_is_safe = mod_safe' - , imv_is_hiding = is_hiding - , imv_all_exports = potential_gres - , imv_qualified = qual_only - } - imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) - - -- Complain if we import a deprecated module - case mi_warns iface of - WarnAll txt -> do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) - noHints - (moduleWarn imp_mod_name txt) - addDiagnostic msg - _ -> return () - - -- Complain about -Wcompat-unqualified-imports violations. - warnUnqualifiedImport decl iface - - let new_imp_decl = ImportDecl - { ideclExt = ideclExt decl - , ideclName = ideclName decl - , ideclPkgQual = pkg_qual - , ideclSource = ideclSource decl - , ideclSafe = mod_safe' - , ideclQualified = ideclQualified decl - , ideclAs = ideclAs decl - , ideclImportList = new_imp_details - } - - return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) - - --- | Rename raw package imports -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual -renameRawPkgQual unit_env mn = \case - NoRawPkgQual -> NoPkgQual - RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) - --- | Rename raw package imports -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual -renamePkgQual unit_env mn mb_pkg = case mb_pkg of - Nothing -> NoPkgQual - Just pkg_fs - | Just uid <- homeUnitId <$> ue_homeUnit unit_env - , pkg_fs == fsLit "this" - -> ThisPkg uid - - | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names - -> ThisPkg uid - - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) - -> OtherPkg uid - - | otherwise - -> OtherPkg (UnitId pkg_fs) - -- not really correct as pkg_fs is unlikely to be a valid unit-id but - -- we will report the failure later... - where - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps - - units = ue_units unit_env - - hpt_deps :: [UnitId] - hpt_deps = homeUnitDepends units - - --- | Calculate the 'ImportAvails' induced by an import of a particular --- interface, but without 'imp_mods'. -calculateAvails :: HomeUnit - -> S.Set UnitId - -> ModIface - -> IsSafeImport - -> IsBootInterface - -> ImportedBy - -> ImportAvails -calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = - let imp_mod = mi_module iface - imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan (mi_final_exts iface) - has_finsts = mi_finsts (mi_final_exts iface) - deps = mi_deps iface - trust = getSafeMode $ mi_trust iface - trust_pkg = mi_trust_pkg iface - is_sig = mi_hsc_src iface == HsigFile - - -- If the module exports anything defined in this module, just - -- ignore it. Reason: otherwise it looks as if there are two - -- local definition sites for the thing, and an error gets - -- reported. Easiest thing is just to filter them out up - -- front. This situation only arises if a module imports - -- itself, or another module that imported it. (Necessarily, - -- this involves a loop.) - -- - -- We do this *after* filterImports, so that if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you won't get a 'B does not export AType' message. - - - -- Compute new transitive dependencies - -- - -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module - -- itself, but we DO need to include this module in 'imp_orphs' and - -- 'imp_finsts' if it defines an orphan or instance family; thus the - -- orph_iface/has_iface tests. - - deporphs = dep_orphs deps - depfinsts = dep_finsts deps - - orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $ - imp_sem_mod : deporphs - | otherwise = deporphs - - finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $ - imp_sem_mod : depfinsts - | otherwise = depfinsts - - -- Trusted packages are a lot like orphans. - trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty - - - pkg = moduleUnit (mi_module iface) - ipkg = toUnitId pkg - - -- Does this import mean we now require our own pkg - -- to be trusted? See Note [Trust Own Package] - ptrust = trust == Sf_Trustworthy || trust_pkg - pkg_trust_req - | isHomeUnit home_unit pkg = ptrust - | otherwise = False - - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton ipkg - - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units - then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) - else S.empty - - dep_boot_mods_map = mkModDeps (dep_boot_mods deps) - - boot_mods - -- If we are looking for a boot module, it must be HPT - | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot) - -- Now we are importing A properly, so don't go looking for - -- A.hs-boot - | isHomeUnit home_unit pkg = dep_boot_mods_map - -- There's no boot files to find in external imports - | otherwise = emptyInstalledModuleEnv - - sig_mods = - if is_sig - then moduleName imp_mod : dep_sig_mods deps - else dep_sig_mods deps - - - in ImportAvails { - imp_mods = unitModuleEnv (mi_module iface) [imported_by], - imp_orphs = orphans, - imp_finsts = finsts, - imp_sig_mods = sig_mods, - imp_direct_dep_mods = direct_mods, - imp_dep_direct_pkgs = dependent_pkgs, - imp_boot_mods = boot_mods, - - -- Add in the imported modules trusted package - -- requirements. ONLY do this though if we import the - -- module as a safe import. - -- See Note [Tracking Trust Transitively] - -- and Note [Trust Transitive Property] - imp_trust_pkgs = trusted_pkgs, - -- Do we require our own pkg to be trusted? - -- See Note [Trust Own Package] - imp_trust_own_pkg = pkg_trust_req - } - - --- | Issue a warning if the user imports Data.List without either an import --- list or `qualified`. This is part of the migration plan for the --- `Data.List.singleton` proposal. See #17244. -warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () -warnUnqualifiedImport decl iface = - when bad_import $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports) - noHints - warning - addDiagnosticAt loc msg - where - mod = mi_module iface - loc = getLocA $ ideclName decl - - is_qual = isImportDeclQualified (ideclQualified decl) - has_import_list = - -- We treat a `hiding` clause as not having an import list although - -- it's not entirely clear this is the right choice. - case ideclImportList decl of - Just (Exactly, _) -> True - _ -> False - bad_import = - not is_qual - && not has_import_list - && mod `elemModuleSet` qualifiedMods - - warning = vcat - [ text "To ensure compatibility with future core libraries changes" - , text "imports to" <+> ppr (ideclName decl) <+> text "should be" - , text "either qualified or have an explicit import list." - ] - - -- Modules for which we warn if we see unqualified imports - qualifiedMods = mkModuleSet [ dATA_LIST ] - - -warnRedundantSourceImport :: ModuleName -> TcRnMessage -warnRedundantSourceImport mod_name - = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ - text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) - -{- -************************************************************************ -* * -\subsection{importsFromLocalDecls} -* * -************************************************************************ - -From the top-level declarations of this module produce - * the lexical environment - * the ImportAvails -created by its bindings. - -Note [Top-level Names in Template Haskell decl quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env - Note [Looking up Exact RdrNames] in GHC.Rename.Env - -Consider a Template Haskell declaration quotation like this: - module M where - f x = h [d| f = 3 |] -When renaming the declarations inside [d| ...|], we treat the -top level binders specially in two ways - -1. We give them an Internal Name, not (as usual) an External one. - This is done by GHC.Rename.Env.newTopSrcBinder. - -2. We make them *shadow* the outer bindings. - See Note [GlobalRdrEnv shadowing] - -3. We find out whether we are inside a [d| ... |] by testing the TH - stage. This is a slight hack, because the stage field was really - meant for the type checker, and here we are not interested in the - fields of Brack, hence the error thunks in thRnBrack. --} - -extendGlobalRdrEnvRn :: [AvailInfo] - -> MiniFixityEnv - -> RnM (TcGblEnv, TcLclEnv) --- Updates both the GlobalRdrEnv and the FixityEnv --- We return a new TcLclEnv only because we might have to --- delete some bindings from it; --- see Note [Top-level Names in Template Haskell decl quotes] - -extendGlobalRdrEnvRn avails new_fixities - = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] - do { (gbl_env, lcl_env) <- getEnvs - ; stage <- getStage - ; isGHCi <- getIsGHCi - ; let rdr_env = tcg_rdr_env gbl_env - fix_env = tcg_fix_env gbl_env - th_bndrs = tcl_th_bndrs lcl_env - th_lvl = thLevel stage - - -- Delete new_occs from global and local envs - -- If we are in a TemplateHaskell decl bracket, - -- we are going to shadow them - -- See Note [GlobalRdrEnv shadowing] - inBracket = isBrackStage stage - - lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs } - -- See Note [GlobalRdrEnv shadowing] - - lcl_env2 | inBracket = lcl_env_TH - | otherwise = lcl_env - - -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] - want_shadowing = isGHCi || inBracket - rdr_env1 | want_shadowing = shadowNames rdr_env new_occs - | otherwise = rdr_env - - lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs - [ ( greNameMangledName n - , (TopLevel, th_lvl) ) - | n <- new_names ] } - - ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres - - ; let fix_env' = foldl' extend_fix_env fix_env new_gres - gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } - - ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) - ; return (gbl_env', lcl_env3) } - where - new_names = concatMap availGreNames avails - new_occs = occSetToEnv (mkOccSet (map occName new_names)) - - -- If there is a fixity decl for the gre, add it to the fixity env - extend_fix_env fix_env gre - | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) - = extendNameEnv fix_env name (FixItem occ fi) - | otherwise - = fix_env - where - name = greMangledName gre - occ = greOccName gre - - new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails - new_gres = concatMap localGREsFromAvail avails - - add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv - -- Extend the GlobalRdrEnv with a LocalDef GRE - -- If there is already a LocalDef GRE with the same OccName, - -- report an error and discard the new GRE - -- This establishes INVARIANT 1 of GlobalRdrEnvs - add_gre env gre - | not (null dups) -- Same OccName defined twice - = do { addDupDeclErr (gre :| dups); return env } - - | otherwise - = return (extendGlobalRdrEnv env gre) - where - -- See Note [Reporting duplicate local declarations] - dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre)) - isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre') - isAllowedDup gre' = - case (isRecFldGRE gre, isRecFldGRE gre') of - (True, True) -> gre_name gre /= gre_name gre' - && isDuplicateRecFldGRE gre' - (True, False) -> isNoFieldSelectorGRE gre - (False, True) -> isNoFieldSelectorGRE gre' - (False, False) -> False - -{- Note [Fail fast on duplicate definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If there are duplicate bindings for the same thing, we want to fail -fast. Having two bindings for the same thing can cause follow-on errors. -Example (test T9975a): - data Test = Test { x :: Int } - pattern Test wat = Test { x = wat } -This defines 'Test' twice. The second defn has no field-names; and then -we get an error from Test { x=wat }, saying "Test has no field 'x'". - -Easiest thing is to bale out fast on duplicate definitions, which -we do via `checkNoErrs` on `extendGlobalRdrEnvRn`. - -Note [Reporting duplicate local declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, a single module may not define the same OccName multiple times. This -is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the -GlobalRdrEnv we report an error if there are already duplicates in the -environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in -GHC.Types.Name.Reader), which says that for a given OccName, all the -GlobalRdrElts to which it maps must have distinct 'gre_name's. - -For example, the following will be rejected: - - f x = x - g x = x - f x = x -- Duplicate! - -Two GREs with the same OccName are OK iff: -------------------------------------------------------------------- - Existing GRE | Newly-defined GRE - | NormalGre FieldGre -------------------------------------------------------------------- - Imported | Always Always - | - Local NormalGre | Never NoFieldSelectors - | - Local FieldGre | NoFieldSelectors DuplicateRecordFields - | and not in same record -------------------------------------------------------------------- - -In this table "NoFieldSelectors" means "NoFieldSelectors was enabled at the -definition site of the fields; ditto "DuplicateRecordFields". These facts are -recorded in the 'FieldLabel' (but where both GREs are local, both will -necessarily have the same extensions enabled). - -More precisely: - -* The programmer is allowed to make a new local definition that clashes with an - imported one (although attempting to refer to either may lead to ambiguity - errors at use sites). For example, the following definition is allowed: - - import M (f) - f x = x - - Thus isDupGRE reports errors only if the existing GRE is a LocalDef. - -* When DuplicateRecordFields is enabled, the same field label may be defined in - multiple records. For example, this is allowed: - - {-# LANGUAGE DuplicateRecordFields #-} - data S1 = MkS1 { f :: Int } - data S2 = MkS2 { f :: Int } - - Even though both fields have the same OccName, this does not violate INVARIANT - 1 of the GlobalRdrEnv, because the fields have distinct selector names, which - form part of the gre_name (see Note [GreNames] in GHC.Types.Name.Reader). - -* However, we must be careful to reject the following (#9156): - - {-# LANGUAGE DuplicateRecordFields #-} - data T = MkT { f :: Int, f :: Int } -- Duplicate! - - In this case, both 'gre_name's are the same (because the fields belong to the - same type), and adding them both to the environment would be a violation of - INVARIANT 1. Thus isAllowedDup checks both GREs have distinct 'gre_name's - if they are both record fields. - -* With DuplicateRecordFields, we reject attempts to define a field and a - non-field with the same OccName (#17965): - - {-# LANGUAGE DuplicateRecordFields #-} - f x = x - data T = MkT { f :: Int} - - In principle this could be supported, but the current "specification" of - DuplicateRecordFields does not allow it. Thus isAllowedDup checks for - DuplicateRecordFields only if *both* GREs being compared are record fields. - -* However, with NoFieldSelectors, it is possible by design to define a field and - a non-field with the same OccName: - - {-# LANGUAGE NoFieldSelectors #-} - f x = x - data T = MkT { f :: Int} - - Thus isAllowedDup checks for NoFieldSelectors if either the existing or the - new GRE are record fields. See Note [NoFieldSelectors] in GHC.Rename.Env. - -See also Note [Skipping ambiguity errors at use sites of local declarations] in -GHC.Rename.Utils. --} - - -{- ********************************************************************* -* * - getLocalDeclBindersd@ returns the names for an HsDecl - It's used for source code. - - *** See Note [The Naming story] in GHC.Hs.Decls **** -* * -********************************************************************* -} - -getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs - -> RnM ((TcGblEnv, TcLclEnv), NameSet) --- Get all the top-level binders bound the group *except* --- for value bindings, which are treated separately --- Specifically we return AvailInfo for --- * type decls (incl constructors and record selectors) --- * class decls (including class ops) --- * associated types --- * foreign imports --- * value signatures (in hs-boot files only) - -getLocalNonValBinders fixity_env - (HsGroup { hs_valds = binds, - hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) - = do { -- Process all type/class decls *except* family instances - ; let inst_decls = tycl_decls >>= group_instds - ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags - ; has_sel <- xopt_FieldSelectors <$> getDynFlags - ; (tc_avails, tc_fldss) - <- fmap unzip $ mapM (new_tc dup_fields_ok has_sel) - (tyClGroupTyClDecls tycl_decls) - ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) - ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env - ; restoreEnvs envs $ do { - -- Bring these things into scope first - -- See Note [Looking up family names in family instances] - - -- Process all family instances - -- to bring new data constructors into scope - ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel) - inst_decls - - -- Finish off with value binders: - -- foreign decls and pattern synonyms for an ordinary module - -- type sigs in case of a hs-boot file only - ; is_boot <- tcIsHsBootOrSig - ; let val_bndrs - | is_boot = case binds of - ValBinds _ _val_binds val_sigs -> - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders - [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] - _ -> panic "Non-ValBinds in hs-boot group" - | otherwise = for_hs_bndrs - ; val_avails <- mapM new_simple val_bndrs - - ; let avails = concat nti_availss ++ val_avails - new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` - availsToNameSetWithSelectors tc_avails - flds = concat nti_fldss ++ concat tc_fldss - ; traceRn "getLocalNonValBinders 2" (ppr avails) - ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env - - -- Force the field access so that tcg_env is not retained. The - -- selector thunk optimisation doesn't kick-in, see #20139 - ; let !old_field_env = tcg_field_env tcg_env - -- Extend tcg_field_env with new fields (this used to be the - -- work of extendRecordFieldEnv) - field_env = extendNameEnvList old_field_env flds - envs = (tcg_env { tcg_field_env = field_env }, tcl_env) - - ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) - ; return (envs, new_bndrs) } } - where - for_hs_bndrs :: [LocatedN RdrName] - for_hs_bndrs = hsForeignDeclsBinders foreign_decls - - -- the SrcSpan attached to the input should be the span of the - -- declaration, not just the name - new_simple :: LocatedN RdrName -> RnM AvailInfo - new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name - ; return (avail nm) } - - new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances - = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs - ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds - ; let fld_env = case unLoc tc_decl of - DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' - _ -> [] - ; return (availTC main_name names flds', fld_env) } - - - -- Calculate the mapping from constructor names to fields, which - -- will go in tcg_field_env. It's convenient to do this here where - -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] - -> [(Name, [FieldLabel])] - mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) - where - find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_args = RecCon cdflds })) - = [( find_con_name rdr - , concatMap find_con_decl_flds (unLoc cdflds) )] - find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_g_args = RecConGADT flds _ })) - = [ ( find_con_name rdr - , concatMap find_con_decl_flds (unLoc flds)) - | L _ rdr <- toList rdrs ] - - find_con_flds _ = [] - - find_con_name rdr - = expectJust "getLocalNonValBinders/find_con_name" $ - find (\ n -> nameOccName n == rdrNameOcc rdr) names - find_con_decl_flds (L _ x) - = map find_con_decl_fld (cd_fld_names x) - - find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) - = expectJust "getLocalNonValBinders/find_con_decl_fld" $ - find (\ fl -> flLabel fl == lbl) flds - where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr) - - new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs - -> RnM ([AvailInfo], [(Name, [FieldLabel])]) - new_assoc _ _ (L _ (TyFamInstD {})) = return ([], []) - -- type instances don't bind new names - - new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) - = do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d - ; return ([avail], flds) } - new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty - , cid_datafam_insts = adts }))) - = do -- First, attempt to grab the name of the class from the instance. - -- This step could fail if the instance is not headed by a class, - -- such as in the following examples: - -- - -- (1) The class is headed by a bang pattern, such as in - -- `instance !Show Int` (#3811c) - -- (2) The class is headed by a type variable, such as in - -- `instance c` (#16385) - -- - -- If looking up the class name fails, then mb_cls_nm will - -- be Nothing. - mb_cls_nm <- runMaybeT $ do - -- See (1) above - L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty - -- See (2) above - MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr - -- Assuming the previous step succeeded, process any associated data - -- family instances. If the previous step failed, bail out. - case mb_cls_nm of - Nothing -> pure ([], []) - Just cls_nm -> do - (avails, fldss) - <- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts - pure (avails, concat fldss) - - new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) - = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) - ; let (bndrs, flds) = hsDataFamInstBinders dfid - ; sub_names <- mapM (newTopSrcBinder .l2n) bndrs - ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds - ; let avail = availTC (unLoc main_name) sub_names flds' - -- main_name is not bound here! - fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' - ; return (avail, fld_env) } - - new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d - -newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel -newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) - = do { selName <- newTopSrcBinder $ L (l2l loc) $ field - ; return $ FieldLabel { flLabel = fieldLabelString - , flHasDuplicateRecordFields = dup_fields_ok - , flHasFieldSelector = has_sel - , flSelector = selName } } - where - fieldLabelString = FieldLabelString $ occNameFS $ rdrNameOcc fld - selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel - field | isExact fld = fld - -- use an Exact RdrName as is to preserve the bindings - -- of an already renamer-resolved field and its use - -- sites. This is needed to correctly support record - -- selectors in Template Haskell. See Note [Binders in - -- Template Haskell] in "GHC.ThToHs" and Note [Looking up - -- Exact RdrNames] in "GHC.Rename.Env". - | otherwise = mkRdrUnqual selOccName - -{- -Note [Looking up family names in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - module M where - type family T a :: * - type instance M.T Int = Bool - -We might think that we can simply use 'lookupOccRn' when processing the type -instance to look up 'M.T'. Alas, we can't! The type family declaration is in -the *same* HsGroup as the type instance declaration. Hence, as we are -currently collecting the binders declared in that HsGroup, these binders will -not have been added to the global environment yet. - -Solution is simple: process the type family declarations first, extend -the environment, and then process the type instances. - - -************************************************************************ -* * -\subsection{Filtering imports} -* * -************************************************************************ - -@filterImports@ takes the @ExportEnv@ telling what the imported module makes -available, and filters it through the import spec (if any). - -Note [Dealing with imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name)) -One entry for each OccName that M exports, mapping each corresponding Name to -its GreName, the AvailInfo exported from M that exports that Name, and -optionally a Name for an associated type's parent class. (Typically there will -be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields] -for why we may need more than one.) - -The situation is made more complicated by associated types. E.g. - module M where - class C a where { data T a } - instance C Int where { data T Int = T1 | T2 } - instance C Bool where { data T Int = T3 } -Then M's export_avails are (recall the AvailTC invariant from Avails.hs) - C(C,T), T(T,T1,T2,T3) -Notice that T appears *twice*, once as a child and once as a parent. From -this list we construct a raw list including - T -> (T, T( T1, T2, T3 ), Nothing) - T -> (T, C( C, T ), Nothing) -and we combine these (in function 'combine' in 'imp_occ_env' in -'filterImports') to get - T -> (T, T(T,T1,T2,T3), Just C) - -So the overall imp_occ_env is - C -> (C, C(C,T), Nothing) - T -> (T, T(T,T1,T2,T3), Just C) - T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 - -If we say - import M( T(T1,T2) ) -then we get *two* Avails: C(T), T(T1,T2) - -Note that the imp_occ_env will have entries for data constructors too, -although we never look up data constructors. - -Note [Importing PatternSynonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Dealing with imports], associated types can lead to the -same Name appearing twice, both as a child and once as a parent, when -constructing the imp_occ_env. The same thing can happen with pattern synonyms -if they are exported bundled with a type. - -A simplified example, based on #11959: - - {-# LANGUAGE PatternSynonyms #-} - module M (T(P), pattern P) where -- Duplicate export warning, but allowed - data T = MkT - pattern P = MkT - -Here we have T(P) and P in export_avails, and construct both - P -> (P, P, Nothing) - P -> (P, T(P), Nothing) -which are 'combine'd to leave - P -> (P, T(P), Nothing) -i.e. we simply discard the non-bundled Avail. - -Note [Importing DuplicateRecordFields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In filterImports, another complicating factor is DuplicateRecordFields. -Suppose we have: - - {-# LANGUAGE DuplicateRecordFields #-} - module M (S(foo), T(foo)) where - data S = MkS { foo :: Int } - data T = mkT { foo :: Int } - - module N where - import M (foo) -- this is allowed (A) - import M (S(foo)) -- this is allowed (B) - -Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo' -maps to a NameEnv containing an entry for each of the two mangled field selector -names (see Note [FieldLabel] in GHC.Types.FieldLabel). - - foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing) - , $sel:foo:MKT -> (foo, T(foo), Nothing) - ] - -Then when we look up 'foo' in lookup_names for case (A) we get both entries and -hence two Avails. Whereas in case (B) we reach the lookup_ie -case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst -its children. - -See T16745 for a test of this. - --} - -filterImports - :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) -- Import spec; True => hiding - -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names - [GlobalRdrElt]) -- Same again, but in GRE form -filterImports iface decl_spec Nothing - = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) - where - imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - -filterImports iface decl_spec (Just (want_hiding, L l import_items)) - = do -- check for errors, convert RdrNames to Names - items1 <- mapM lookup_lie import_items - - let items2 :: [(LIE GhcRn, AvailInfo)] - items2 = concat items1 - -- NB the AvailInfo may have duplicates, and several items - -- for the same parent; e.g N(x) and N(y) - - names = availsToNameSetWithSelectors (map snd items2) - keep n = not (n `elemNameSet` names) - pruned_avails = filterAvails keep all_avails - hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - gres | want_hiding == EverythingBut = gresFromAvails (Just hiding_spec) pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 - - return (Just (want_hiding, L l (map fst items2)), gres) - where - all_avails = mi_exports iface - - -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (NameEnv (GreName, -- the name or field - AvailInfo, -- the export item providing it - Maybe Name)) -- the parent of associated types - imp_occ_env = mkOccEnv_C (plusNameEnv_C combine) - [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))]) - | a <- all_avails - , c <- availGreNames a] - -- See Note [Dealing with imports] - -- 'combine' may be called for associated data types which appear - -- twice in the all_avails. In the example, we combine - -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) - -- NB: the AvailTC can have fields as well as data constructors (#12127) - combine :: (GreName, AvailInfo, Maybe Name) - -> (GreName, AvailInfo, Maybe Name) - -> (GreName, AvailInfo, Maybe Name) - combine (NormalGreName name1, a1@(AvailTC p1 _), mb1) - (NormalGreName name2, a2@(AvailTC p2 _), mb2) - = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2) - (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $ - if p1 == name1 then (NormalGreName name1, a1, Just p2) - else (NormalGreName name1, a2, Just p1) - -- 'combine' may also be called for pattern synonyms which appear both - -- unassociated and associated (see Note [Importing PatternSynonyms]). - combine (c1, a1, mb1) (c2, a2, mb2) - = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2 - && (isAvailTC a1 || isAvailTC a2)) - (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $ - if isAvailTC a1 then (c1, a1, Nothing) - else (c1, a2, Nothing) - - isAvailTC AvailTC{} = True - isAvailTC _ = False - - -- Look up a RdrName used in an import, failing if it is ambiguous - -- (e.g. because it refers to multiple record fields) - lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) - lookup_name ie rdr = do - xs <- lookup_names ie rdr - case xs of - [cax] -> return cax - _ -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs)) - - -- Look up a RdrName used in an import, returning multiple values if there - -- are several fields with the same name exposed by the module - lookup_names :: IE GhcPs -> RdrName -> IELookupM [(Name, AvailInfo, Maybe Name)] - lookup_names ie rdr - | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return $ map (\ (c,a,x) -> (greNameMangledName c, a, x)) (nonDetNameEnvElts succ) - | otherwise = failLookupWith (BadImport ie) - where - mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) - - lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] - lookup_lie (L loc ieRdr) - = do (stuff, warns) <- setSrcSpanA loc $ - liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie ieRdr) - mapM_ emit_warning warns - return [ (L loc ie, avail) | (ie,avail) <- stuff ] - where - -- Warn when importing T(..) if T was exported abstractly - emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addTcRnDiagnostic (TcRnDodgyImports n) - emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addTcRnDiagnostic (TcRnMissingImportList ieRdr) - emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports) - noHints - (lookup_err_msg (BadImport ie)) - addDiagnostic msg - - run_lookup :: IELookupM a -> TcRn (Maybe a) - run_lookup m = case m of - Failed err -> do - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) - return Nothing - Succeeded a -> return (Just a) - - lookup_err_msg err = case err of - BadImport ie -> badImportItemErr iface decl_spec ie all_avails - IllegalImport -> illegalImportItemErr - QualImportError rdr -> qualImportItemErr rdr - AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs - - -- For each import item, we convert its RdrNames to Names, - -- and at the same time construct an AvailInfo corresponding - -- to what is actually imported by this item. - -- Returns Nothing on error. - -- We return a list here, because in the case of an import - -- item like C, if we are hiding, then C refers to *both* a - -- type/class and a data constructor. Moreover, when we import - -- data constructors of an associated family, we need separate - -- AvailInfos for the data constructors and the family (as they have - -- different parents). See Note [Dealing with imports] - lookup_ie :: IE GhcPs - -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) - lookup_ie ie = handle_bad_import $ - case ie of - IEVar _ (L l n) -> do - -- See Note [Importing DuplicateRecordFields] - xs <- lookup_names ie (ieWrappedName n) - return ([(IEVar noExtField (L l (replaceWrappedName n name)), - trimAvail avail name) - | (name, avail, _) <- xs ], []) - - IEThingAll _ (L l tc) -> do - (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc - let warns = case avail of - Avail {} -- e.g. f(..) - -> [DodgyImport $ ieWrappedName tc] - - AvailTC _ subs - | null (drop 1 subs) -- e.g. T(..) where T is a synonym - -> [DodgyImport $ ieWrappedName tc] - - | not (is_qual decl_spec) -- e.g. import M( T(..) ) - -> [MissingImportList] - - | otherwise - -> [] - - renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name)) - sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))] - case mb_parent of - Nothing -> return ([(renamed_ie, avail)], warns) - -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns) - -- associated type - - IEThingAbs _ (L l tc') - | want_hiding == EverythingBut -- hiding ( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - -> let tc = ieWrappedName tc' - tc_name = lookup_name ie tc - dc_name = lookup_name ie (setRdrNameSpace tc srcDataName) - in - case catIELookupM [ tc_name, dc_name ] of - [] -> failLookupWith (BadImport ie) - names -> return ([mkIEThingAbs tc' l name | name <- names], []) - | otherwise - -> do nameAvail <- lookup_name ie (ieWrappedName tc') - return ([mkIEThingAbs tc' l nameAvail] - , []) - - IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do - (name, avail, mb_parent) - <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc) - - -- Look up the children in the sub-names of the parent - -- See Note [Importing DuplicateRecordFields] - let subnames = availSubordinateGreNames avail - case lookupChildren subnames rdr_ns of - - Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs)) - -- We are trying to import T( a,b,c,d ), and failed - -- to find 'b' and 'd'. So we make up an import item - -- to report as failing, namely T( b, d ). - -- c.f. #15412 - - Succeeded (childnames, childflds) -> - case mb_parent of - -- non-associated ty/cls - Nothing - -> return ([(IEThingWith childflds (L l name') wc childnames', - availTC name (name:map unLoc childnames) (map unLoc childflds))], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - -- childnames' = postrn_ies childnames - -- associated ty - Just parent - -> return ([(IEThingWith childflds (L l name') wc childnames', - availTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith childflds (L l name') wc childnames', - availTC parent [name] [])], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - - _other -> failLookupWith IllegalImport - -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed - -- all errors. - - where - mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n) - mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs noAnn (L l (replaceWrappedName tc n)) - , availTC parent [n] []) - - handle_bad_import m = catchIELookup m $ \err -> case err of - BadImport ie | want_hiding == EverythingBut -> return ([], [BadImportW ie]) - _ -> failLookupWith err - -type IELookupM = MaybeErr IELookupError - -data IELookupWarning - = BadImportW (IE GhcPs) - | MissingImportList - | DodgyImport RdrName - -- NB. use the RdrName for reporting a "dodgy" import - -data IELookupError - = QualImportError RdrName - | BadImport (IE GhcPs) - | IllegalImport - | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import - -failLookupWith :: IELookupError -> IELookupM a -failLookupWith err = Failed err - -catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a -catchIELookup m h = case m of - Succeeded r -> return r - Failed err -> h err - -catIELookupM :: [IELookupM a] -> [a] -catIELookupM ms = [ a | Succeeded a <- ms ] - -{- -************************************************************************ -* * -\subsection{Import/Export Utils} -* * -************************************************************************ --} - --- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] -gresFromIE decl_spec (L loc ie, avail) - = gresFromAvail prov_fn avail - where - is_explicit = case ie of - IEThingAll _ name -> \n -> n == lieWrappedName name - _ -> \_ -> True - prov_fn name - = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) - where - item_spec = ImpSome { is_explicit = is_explicit name - , is_iloc = locA loc } - - -{- -Note [Children for duplicate record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the module - - {-# LANGUAGE DuplicateRecordFields #-} - module M (F(foo, MkFInt, MkFBool)) where - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool } - -The `foo` in the export list refers to *both* selectors! For this -reason, lookupChildren builds an environment that maps the FastString -to a list of items, rather than a single item. --} - -mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] -mkChildEnv gres = foldr add emptyNameEnv gres - where - add gre env = case gre_par gre of - ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre - NoParent -> env - -findChildren :: NameEnv [a] -> Name -> [a] -findChildren env n = lookupNameEnv env n `orElse` [] - -lookupChildren :: [GreName] -> [LIEWrappedName GhcPs] - -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed - ([LocatedA Name], [Located FieldLabel]) --- (lookupChildren all_kids rdr_items) maps each rdr_item to its --- corresponding Name all_kids, if the former exists --- The matching is done by FastString, not OccName, so that --- Cls( meth, AssocTy ) --- will correctly find AssocTy among the all_kids of Cls, even though --- the RdrName for AssocTy may have a (bogus) DataName namespace --- (Really the rdr_items should be FastStrings in the first place.) -lookupChildren all_kids rdr_items - | null fails - = Succeeded (fmap concat (partitionEithers oks)) - -- This 'fmap concat' trickily applies concat to the /second/ component - -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]]) - | otherwise - = Failed fails - where - mb_xs = map doOne rdr_items - fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] - oks = [ ok | Succeeded ok <- mb_xs ] - oks :: [Either (LocatedA Name) [Located FieldLabel]] - - doOne item@(L l r) - = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [NormalGreName n] -> Succeeded (Left (L l n)) - Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs)) - _ -> Failed item - - -- See Note [Children for duplicate record fields] - kid_env = extendFsEnvList_C (++) emptyFsEnv - [(occNameFS (occName x), [x]) | x <- all_kids] - - - -------------------------------- - -{- -********************************************************* -* * -\subsection{Unused names} -* * -********************************************************* --} - -reportUnusedNames :: TcGblEnv -> HscSource -> RnM () -reportUnusedNames gbl_env hsc_src - = do { keep <- readTcRef (tcg_keep gbl_env) - ; traceRn "RUN" (ppr (tcg_dus gbl_env)) - ; warnUnusedImportDecls gbl_env hsc_src - ; warnUnusedTopBinds $ unused_locals keep - ; warnMissingSignatures gbl_env - ; warnMissingKindSignatures gbl_env } - where - used_names :: NameSet -> NameSet - used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep - -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used - -- Hence findUses - - -- Collect the defined names from the in-scope environment - defined_names :: [GlobalRdrElt] - defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) - - kids_env = mkChildEnv defined_names - -- This is done in mkExports too; duplicated work - - gre_is_used :: NameSet -> GlobalRdrElt -> Bool - gre_is_used used_names gre0 - = name `elemNameSet` used_names - || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name) - -- A use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - where - name = greMangledName gre0 - - -- Filter out the ones that are - -- (a) defined in this module, and - -- (b) not defined by a 'deriving' clause - -- The latter have an Internal Name, so we can filter them out easily - unused_locals :: NameSet -> [GlobalRdrElt] - unused_locals keep = - let -- Note that defined_and_used, defined_but_not_used - -- are both [GRE]; that's why we need defined_and_used - -- rather than just used_names - _defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (_defined_and_used, defined_but_not_used) - = partition (gre_is_used (used_names keep)) defined_names - - in filter is_unused_local defined_but_not_used - is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre) - -{- ********************************************************************* -* * - Missing signatures -* * -********************************************************************* -} - -{- -Note [Missing signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There are four warning flags in play: - - * -Wmissing-exported-signatures - Warn about any exported top-level function/value without a type signature. - Does not include pattern synonyms. - - * -Wmissing-signatures - Warn about any top-level function/value without a type signature. Does not - include pattern synonyms. Takes priority over -Wmissing-exported-signatures. - - * -Wmissing-exported-pattern-synonym-signatures - Warn about any exported pattern synonym without a type signature. - - * -Wmissing-pattern-synonym-signatures - Warn about any pattern synonym without a type signature. Takes priority over - -Wmissing-exported-pattern-synonym-signatures. - --} - --- | Warn the user about top level binders that lack type signatures. --- Called /after/ type inference, so that we can report the --- inferred type of the function -warnMissingSignatures :: TcGblEnv -> RnM () -warnMissingSignatures gbl_env - = do { warn_binds <- woptM Opt_WarnMissingSignatures - ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures - ; let exports = availsToNameSet (tcg_exports gbl_env) - sig_ns = tcg_sigs gbl_env - -- We use sig_ns to exclude top-level bindings that are generated by GHC - binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env - pat_syns = tcg_patsyns gbl_env - - not_ghc_generated :: Name -> Bool - not_ghc_generated name = name `elemNameSet` sig_ns - - add_binding_warn :: Id -> RnM () - add_binding_warn id = - when (not_ghc_generated name) $ - do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? - ; let (_, ty) = tidyOpenType env (idType id) - missing = MissingTopLevelBindingSig name ty - diag = TcRnMissingSignature missing exported warn_binds - ; addDiagnosticAt (getSrcSpan name) diag } - where - name = idName id - exported = if name `elemNameSet` exports - then IsExported - else IsNotExported - - add_patsyn_warn :: PatSyn -> RnM () - add_patsyn_warn ps = - when (not_ghc_generated name) $ - addDiagnosticAt (getSrcSpan name) - (TcRnMissingSignature missing exported warn_pat_syns) - where - name = patSynName ps - missing = MissingPatSynSig ps - exported = if name `elemNameSet` exports - then IsExported - else IsNotExported - - -- Warn about missing signatures - -- Do this only when we have a type to offer - -- See Note [Missing signatures] - ; mapM_ add_binding_warn binds - ; mapM_ add_patsyn_warn pat_syns - } - --- | Warn the user about tycons that lack kind signatures. --- Called /after/ type (and kind) inference, so that we can report the --- inferred kinds. -warnMissingKindSignatures :: TcGblEnv -> RnM () -warnMissingKindSignatures gbl_env - = do { cusks_enabled <- xoptM LangExt.CUSKs - ; mapM_ (add_ty_warn cusks_enabled) tcs - } - where - tcs = tcg_tcs gbl_env - ksig_ns = tcg_ksigs gbl_env - exports = availsToNameSet (tcg_exports gbl_env) - not_ghc_generated :: Name -> Bool - not_ghc_generated name = name `elemNameSet` ksig_ns - - add_ty_warn :: Bool -> TyCon -> RnM () - add_ty_warn cusks_enabled tyCon = - when (not_ghc_generated name) $ - addDiagnosticAt (getSrcSpan name) diag - where - name = tyConName tyCon - diag = TcRnMissingSignature missing exported False - missing = MissingTyConKindSig tyCon cusks_enabled - exported = if name `elemNameSet` exports - then IsExported - else IsNotExported - -{- -********************************************************* -* * -\subsection{Unused imports} -* * -********************************************************* - -This code finds which import declarations are unused. The -specification and implementation notes are here: - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports - -See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader --} - -type ImportDeclUsage - = ( LImportDecl GhcRn -- The import declaration - , [GlobalRdrElt] -- What *is* used (normalised) - , [Name] ) -- What is imported but *not* used - -warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () -warnUnusedImportDecls gbl_env hsc_src - = do { uses <- readMutVar (tcg_used_gres gbl_env) - ; let user_imports = filterOut - (ideclImplicit . ideclExt . unLoc) - (tcg_rn_imports gbl_env) - -- This whole function deals only with *user* imports - -- both for warning about unnecessary ones, and for - -- deciding the minimal ones - rdr_env = tcg_rdr_env gbl_env - fld_env = mkFieldEnv rdr_env - - ; let usage :: [ImportDeclUsage] - usage = findImportUsage user_imports uses - - ; traceRn "warnUnusedImportDecls" $ - (vcat [ text "Uses:" <+> ppr uses - , text "Import usage" <+> ppr usage]) - - ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage - - ; whenGOptM Opt_D_dump_minimal_imports $ - printMinimalImports hsc_src usage } - -findImportUsage :: [LImportDecl GhcRn] - -> [GlobalRdrElt] - -> [ImportDeclUsage] - -findImportUsage imports used_gres - = map unused_decl imports - where - import_usage :: ImportMap - import_usage = mkImportMap used_gres - - unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) - unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) - = (decl, used_gres, nameSetElemsStable unused_imps) - where - used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage - -- srcSpanEnd: see Note [The ImportMap] - `orElse` [] - - used_names = mkNameSet (map greMangledName used_gres) - used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) - - unused_imps -- Not trivial; see eg #7454 - = case imps of - Just (Exactly, L _ imp_ies) -> - foldr (add_unused . unLoc) emptyNameSet imp_ies - _other -> emptyNameSet -- No explicit import list => no unused-name list - - add_unused :: IE GhcRn -> NameSet -> NameSet - add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc - add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc - add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc - add_unused (IEThingWith fs p wc ns) acc = - add_wc_all (add_unused_with pn xs acc) - where pn = lieWrappedName p - xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs - add_wc_all = case wc of - NoIEWildcard -> id - IEWildcard _ -> add_unused_all pn - add_unused _ acc = acc - - add_unused_name n acc - | n `elemNameSet` used_names = acc - | otherwise = acc `extendNameSet` n - add_unused_all n acc - | n `elemNameSet` used_names = acc - | n `elemNameSet` used_parents = acc - | otherwise = acc `extendNameSet` n - add_unused_with p ns acc - | all (`elemNameSet` acc1) ns = add_unused_name p acc1 - | otherwise = acc1 - where - acc1 = foldr add_unused_name acc ns - -- If you use 'signum' from Num, then the user may well have - -- imported Num(signum). We don't want to complain that - -- Num is not itself mentioned. Hence the two cases in add_unused_with. - - -{- Note [The ImportMap] -~~~~~~~~~~~~~~~~~~~~~~~ -The ImportMap is a short-lived intermediate data structure records, for -each import declaration, what stuff brought into scope by that -declaration is actually used in the module. - -The SrcLoc is the location of the END of a particular 'import' -declaration. Why *END*? Because we don't want to get confused -by the implicit Prelude import. Consider (#7476) the module - import Foo( foo ) - main = print foo -There is an implicit 'import Prelude(print)', and it gets a SrcSpan -of line 1:1 (just the point, not a span). If we use the *START* of -the SrcSpan to identify the import decl, we'll confuse the implicit -import Prelude with the explicit 'import Foo'. So we use the END. -It's just a cheap hack; we could equally well use the Span too. - -The [GlobalRdrElt] are the things imported from that decl. --} - -type ImportMap = Map RealSrcLoc [GlobalRdrElt] -- See [The ImportMap] - -- If loc :-> gres, then - -- 'loc' = the end loc of the bestImport of each GRE in 'gres' - -mkImportMap :: [GlobalRdrElt] -> ImportMap --- For each of a list of used GREs, find all the import decls that brought --- it into scope; choose one of them (bestImport), and record --- the RdrName in that import decl's entry in the ImportMap -mkImportMap gres - = foldr add_one Map.empty gres - where - add_one gre@(GRE { gre_imp = imp_specs }) imp_map = - case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of - -- For srcSpanEnd see Note [The ImportMap] - RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map - UnhelpfulLoc _ -> imp_map - where - best_imp_spec = bestImport (bagToList imp_specs) - add _ gres = gre : gres - -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) - -> ImportDeclUsage -> RnM () -warnUnusedImport flag fld_env (L loc decl, used, unused) - - -- Do not warn for 'import M()' - | Just (Exactly, L _ []) <- ideclImportList decl - = return () - - -- Note [Do not warn about Prelude hiding] - | Just (EverythingBut, L _ hides) <- ideclImportList decl - , not (null hides) - , pRELUDE_NAME == unLoc (ideclName decl) - = return () - - -- Nothing used; drop entire declaration - | null used - = let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints msg1 - in addDiagnosticAt (locA loc) dia - - -- Everything imported is used; nop - | null unused - = return () - - -- Only one import is unused, with `SrcSpan` covering only the unused item instead of - -- the whole import statement - | Just (_, L _ imports) <- ideclImportList decl - , length unused == 1 - , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 - in addDiagnosticAt (locA loc) dia - - -- Some imports are unused - | otherwise - = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 - in addDiagnosticAt (locA loc) dia - - where - msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant - , nest 2 (text "except perhaps to import instances from" - <+> quotes pp_mod) - , text "To import instances alone, use:" - <+> text "import" <+> pp_mod <> parens Outputable.empty ] - msg2 = sep [ pp_herald <+> quotes sort_unused - , text "from module" <+> quotes pp_mod <+> is_redundant] - pp_herald = text "The" <+> pp_qual <+> text "import of" - pp_qual - | isImportDeclQualified (ideclQualified decl)= text "qualified" - | otherwise = Outputable.empty - pp_mod = ppr (unLoc (ideclName decl)) - is_redundant = text "is redundant" - - -- In warning message, pretty-print identifiers unqualified unconditionally - -- to improve the consistent for ambiguous/unambiguous identifiers. - -- See trac#14881. - ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld) - Just (fld, NoParent) -> ppr fld - Nothing -> pprNameUnqualified n - - -- Print unused names in a deterministic (lexicographic) order - sort_unused :: SDoc - sort_unused = pprWithCommas ppr_possible_field $ - sortBy (comparing nameOccName) unused - -{- -Note [Do not warn about Prelude hiding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not warn about - import Prelude hiding( x, y ) -because even if nothing else from Prelude is used, it may be essential to hide -x,y to avoid name-shadowing warnings. Example (#9061) - import Prelude hiding( log ) - f x = log where log = () - - - -Note [Printing minimal imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To print the minimal imports we walk over the user-supplied import -decls, and simply trim their import lists. NB that - - * We do *not* change the 'qualified' or 'as' parts! - - * We do not discard a decl altogether; we might need instances - from it. Instead we just trim to an empty import list --} - -getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] -getMinimalImports = fmap combine . mapM mk_minimal - where - mk_minimal (L l decl, used_gres, unused) - | null unused - , Just (Exactly, _) <- ideclImportList decl - = return (L l decl) - | otherwise - = do { let ImportDecl { ideclName = L _ mod_name - , ideclSource = is_boot - , ideclPkgQual = pkg_qual } = decl - ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual - ; let used_avails = gresToAvailInfo used_gres - lies = map (L l) (concatMap (to_ie iface) used_avails) - ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } - where - doc = text "Compute minimal imports for" <+> ppr decl - - to_ie :: ModIface -> AvailInfo -> [IE GhcRn] - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail c) -- Note [Overloaded field import] - = [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))] - to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else - | availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)] - to_ie iface (AvailTC n cs) - = case [xs | avail@(AvailTC x xs) <- mi_exports iface - , x == n - , availExportsDecl avail -- Note [Partial export] - ] of - [xs] | all_used xs -> - [IEThingAll noAnn (to_ie_post_rn $ noLocA n)] - | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] - -- Note [Overloaded field import] - _other | all_non_overloaded fs - -> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns - ++ map flSelector fs - | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] - where - (ns, fs) = partitionGreNames cs - - all_used avail_cs = all (`elem` cs) avail_cs - - all_non_overloaded = all (not . flIsOverloaded) - - combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] - combine = map merge . NE.groupAllWith getKey - - getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName) - getKey decl = - ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first) - , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad) - , unLoc . ideclName $ idecl -- Module Name - ) - where - idecl :: ImportDecl GhcRn - idecl = unLoc decl - - merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn - merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) }) - where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls - - -printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () --- See Note [Printing minimal imports] -printMinimalImports hsc_src imports_w_usage - = do { imports' <- getMinimalImports imports_w_usage - ; this_mod <- getModule - ; dflags <- getDynFlags - ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> - printForUser dflags h neverQualify AllTheWay (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 - -- E.g. import Blag( f, b ) - -- not import Blag( Blag.f, Blag.g )! - } - where - mkFilename dflags this_mod - | Just d <- dumpDir dflags = d basefn - | otherwise = basefn - where - suffix = case hsc_src of - HsBootFile -> ".imports-boot" - HsSrcFile -> ".imports" - HsigFile -> ".imports" - basefn = moduleNameString (moduleName this_mod) ++ suffix - - -to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn -to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n)) - | otherwise = L l (IEName noExtField (L (la2na l) n)) - - -to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn -to_ie_post_rn (L l n) - | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n)) - | otherwise = L l (IEName noExtField (L (la2na l) n)) - where occ = occName n - -{- -Note [Partial export] -~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - module A( op ) where - class C a where - op :: a -> a - - module B where - import A - f = ..op... - -Then the minimal import for module B is - import A( op ) -not - import A( C( op ) ) -which we would usually generate if C was exported from B. Hence -the availExportsDecl test when deciding what to generate. - - -Note [Overloaded field import] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On the other hand, if we have - - {-# LANGUAGE DuplicateRecordFields #-} - module A where - data T = MkT { foo :: Int } - - module B where - import A - f = ...foo... - -then the minimal import for module B must be - import A ( T(foo) ) -because when DuplicateRecordFields is enabled, field selectors are -not in scope without their enclosing datatype. - -On the third hand, if we have - - {-# LANGUAGE DuplicateRecordFields #-} - module A where - pattern MkT { foo } = Just foo - - module B where - import A - f = ...foo... - -then the minimal import for module B must be - import A ( foo ) -because foo doesn't have a parent. This might actually be ambiguous if A -exports another field called foo, but there is no good answer to return and this -is a very obscure corner, so it seems to be the best we can do. See -DRFPatSynExport for a test of this. - - -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -qualImportItemErr :: RdrName -> SDoc -qualImportItemErr rdr - = hang (text "Illegal qualified name in import item:") - 2 (ppr rdr) - -ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc -ambiguousImportItemErr rdr avails - = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") - 2 (vcat (map ppr_avail avails)) - where - ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr) - ppr_avail (Avail name) = ppr name - -pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc -pprImpDeclSpec iface decl_spec = - quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of - IsBoot -> text "(hi-boot interface)" - NotBoot -> Outputable.empty - -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc -badImportItemErrStd iface decl_spec ie - = sep [text "Module", pprImpDeclSpec iface decl_spec, - text "does not export", quotes (ppr ie)] - -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs - -> SDoc -badImportItemErrDataCon dataType_occ iface decl_spec ie - = vcat [ text "In module" - <+> pprImpDeclSpec iface decl_spec - <> colon - , nest 2 $ quotes datacon - <+> text "is a data constructor of" - <+> quotes dataType - , text "To import it use" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> parens_sp datacon) - , text "or" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> text "(..)") - ] - where - datacon_occ = rdrNameOcc $ ieName ie - datacon = parenSymOcc datacon_occ (ppr datacon_occ) - dataType = parenSymOcc dataType_occ (ppr dataType_occ) - parens_sp d = parens (space <> d <> space) -- T( f,g ) - -badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc -badImportItemErr iface decl_spec ie avails - = case find checkIfDataCon avails of - Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie - Nothing -> badImportItemErrStd iface decl_spec ie - where - checkIfDataCon (AvailTC _ ns) = - case find (\n -> importedFS == occNameFS (occName n)) ns of - Just n -> isDataConName (greNameMangledName n) - Nothing -> False - checkIfDataCon _ = False - availOccName = occName . availGreName - importedFS = occNameFS . rdrNameOcc $ ieName ie - -illegalImportItemErr :: SDoc -illegalImportItemErr = text "Illegal import item" - -addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () -addDupDeclErr gres@(gre :| _) - = addErrAt (getSrcSpan (NE.last sorted_names)) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - -- Report the error at the later location - vcat [text "Multiple declarations of" <+> - 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 (toList $ ppr . nameSrcLoc <$> sorted_names)] - where - sorted_names = - NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) - (fmap greMangledName gres) - - - -missingImportListWarn :: ModuleName -> SDoc -missingImportListWarn mod - = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" - -moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc -moduleWarn mod (WarningTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) <> colon, - nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] -moduleWarn mod (DeprecatedTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) - <+> text "is deprecated:", - nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] - -packageImportErr :: TcRnMessage -packageImportErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Package-qualified imports are not enabled; use PackageImports" - --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form --- --- We also allow type constructor names, which are defined by "type data" --- declarations. See Note [Type data declarations] in GHC.Rename.Module. - -checkConName :: RdrName -> TcRn () -checkConName name - = checkErr (isRdrDataCon name || isRdrTc name) (badDataCon name) - -badDataCon :: RdrName -> TcRnMessage -badDataCon name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "Illegal data constructor name", quotes (ppr name)] +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Rename.Names ( + rnImports, getLocalNonValBinders, newRecordFieldLabel, + extendGlobalRdrEnvRn, + gresFromAvails, + calculateAvails, + reportUnusedNames, + checkConName, + mkChildEnv, + findChildren, + findImportUsage, + getMinimalImports, + printMinimalImports, + renamePkgQual, renameRawPkgQual, + classifyGREs, + ImportDeclUsage, + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr + +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( warnUnusedTopBinds ) +import GHC.Rename.Unbound +import qualified GHC.Rename.Unbound as Unbound + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.LclEnv +import GHC.Tc.Zonk.TcType ( tcInitTidyEnv ) + +import GHC.Hs +import GHC.Iface.Load ( loadSrcInterface ) +import GHC.Iface.Syntax ( fromIfaceWarnings ) +import GHC.Builtin.Names +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Core.Type +import GHC.Core.PatSyn +import GHC.Core.TyCon ( TyCon, tyConName ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Panic + +import GHC.Types.Fixity.Env +import GHC.Types.SafeHaskell +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Avail +import GHC.Types.FieldLabel +import GHC.Types.Hint +import GHC.Types.SourceFile +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.HpcInfo +import GHC.Types.PkgQual +import GHC.Types.GREInfo (ConInfo(..)) + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps +import GHC.Unit.Env + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Data.Maybe +import GHC.Data.List.SetOps ( removeDups ) + +import Control.Monad +import Data.Foldable ( for_ ) +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IntMap +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Ord ( comparing ) +import Data.List ( partition, find, sortBy ) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Function ( on ) +import qualified Data.Set as S +import System.FilePath (()) +import System.IO + + +{- +************************************************************************ +* * +\subsection{rnImports} +* * +************************************************************************ + +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependency +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompilation being triggered: package trust. So we must check that all +packages a module transitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +GHC.Driver.Main.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. +-} + +-- | Process Import Decls. See 'rnImportDecl' for a description of what +-- the return types represent. +-- Note: Do the non SOURCE ones first, so that we get a helpful warning +-- for SOURCE ones that are unnecessary +rnImports :: [(LImportDecl GhcPs, SDoc)] + -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports imports = do + tcg_env <- getGblEnv + -- NB: want an identity module here, because it's OK for a signature + -- module to import from its implementor + let this_mod = tcg_mod tcg_env + let (source, ordinary) = partition (is_source_import . fst) imports + is_source_import d = ideclSource (unLoc d) == IsBoot + stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary + stuff2 <- mapAndReportM (rnImportDecl this_mod) source + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) + -- Update imp_boot_mods if imp_direct_mods mentions any of them + let merged_import_avail = clobberSourceImports imp_avails + dflags <- getDynFlags + let final_import_avail = + merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) + `S.union` imp_dep_direct_pkgs merged_import_avail} + return (decls, rdr_env, final_import_avail, hpc_usage) + + where + clobberSourceImports imp_avails = + imp_avails { imp_boot_mods = imp_boot_mods' } + where + imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv) + (imp_boot_mods imp_avails) + (imp_direct_dep_mods imp_avails) + + combJ (GWIB _ IsBoot) x = Just x + combJ r _ = Just r + -- See Note [Combining ImportAvails] + combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine ss = + let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr + plus + ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) + ss + in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, + hpc_usage) + + plus (decl, gbl_env1, imp_avails1, hpc_usage1) + (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1' `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2, + extendModuleSetList finsts_set new_finsts ) + where + imp_avails1' = imp_avails1 { imp_finsts = [] } + new_finsts = imp_finsts imp_avails1 + +{- +Note [Combining ImportAvails] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +imp_finsts in ImportAvails is a list of family instance modules +transitively depended on by an import. imp_finsts for a currently +compiled module is a union of all the imp_finsts of imports. +Computing the union of two lists of size N is O(N^2) and if we +do it to M imports we end up with O(M*N^2). That can get very +expensive for bigger module hierarchies. + +Union can be optimized to O(N log N) if we use a Set. +imp_finsts is converted back and forth between dep_finsts, so +changing a type of imp_finsts means either paying for the conversions +or changing the type of dep_finsts as well. + +I've measured that the conversions would cost 20% of allocations on my +test case, so that can be ruled out. + +Changing the type of dep_finsts forces checkFamInsts to +get the module lists in non-deterministic order. If we wanted to restore +the deterministic order, we'd have to sort there, which is an additional +cost. As far as I can tell, using a non-deterministic order is fine there, +but that's a brittle nonlocal property which I'd like to avoid. + +Additionally, dep_finsts is read from an interface file, so its "natural" +type is a list. Which makes it a natural type for imp_finsts. + +Since rnImports.combine is really the only place that would benefit from +it being a Set, it makes sense to optimize the hot loop in rnImports.combine +without changing the representation. + +So here's what we do: instead of naively merging ImportAvails with +plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts +and compute the union on the side using Sets. When we're done, we can +convert it back to a list. One nice side effect of this approach is that +if there's a lot of overlap in the imp_finsts of imports, the +Set doesn't really need to grow and we don't need to allocate. + +Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in +23s before, and 11s after. +-} + + + +-- | Given a located import declaration @decl@ from @this_mod@, +-- calculate the following pieces of information: +-- +-- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in +-- the entity lists have been resolved into 'Name's, +-- +-- 2. A 'GlobalRdrEnv' representing the new identifiers that were +-- brought into scope (taking into account module qualification +-- and hiding), +-- +-- 3. 'ImportAvails' summarizing the identifiers that were imported +-- by this declaration, and +-- +-- 4. A boolean 'AnyHpcUsage' which is true if the imported module +-- used HPC. +rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc) + -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImportDecl this_mod + (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name + , ideclPkgQual = raw_pkg_qual + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_style + , ideclExt = XImportDeclPass { ideclImplicit = implicit } + , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) + = setSrcSpanA loc $ do + + case raw_pkg_qual of + NoRawPkgQual -> pure () + RawPkgQual _ -> do + pkg_imports <- xoptM LangExt.PackageImports + when (not pkg_imports) $ addErr TcRnPackageImportsDisabled + + let qual_only = isImportDeclQualified qual_style + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + let imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> import_reason + + hsc_env <- getTopEnv + unit_env <- hsc_unit_env <$> getTopEnv + let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + + -- Check for self-import, which confuses the typechecker (#9032) + -- ghc --make rejects self-import cycles already, but batch-mode may not + -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid + -- typechecker crashes. (Indirect self imports are not caught until + -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) + -- + -- Originally, we also allowed 'import {-# SOURCE #-} M', but this + -- caused bug #10182: in one-shot mode, we should never load an hs-boot + -- file for the module we are compiling into the EPS. In principle, + -- it should be possible to support this mode of use, but we would have to + -- extend Provenance to support a local definition in a qualified location. + -- For now, we don't support it, but see #10336 + when (imp_mod_name == moduleName this_mod && + (case pkg_qual of -- If we have import "" M, then we should + -- check that "" is "this" (which is magic) + -- or the name of this_mod's package. Yurgh! + -- c.f. GHC.findModule, and #9997 + NoPkgQual -> True + ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) + OtherPkg _ -> False)) + (addErr (TcRnSelfImport imp_mod_name)) + + -- Check for a missing import list (Opt_WarnMissingImportList also + -- checks for T(..) items but that is done in checkDodgyImport below) + case imp_details of + Just (Exactly, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> addDiagnostic (TcRnNoExplicitImportList imp_mod_name) + + + iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual + + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do + + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. + -- + -- in --make and GHCi, the compilation manager checks for this, + -- and indeed we shouldn't do it here because the existence of + -- the non-boot module depends on the compilation order, which + -- is not deterministic. The hs-boot test can show this up. + dflags <- getDynFlags + warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) + (TcRnRedundantSourceImport imp_mod_name) + when (mod_safe && not (safeImportsOn dflags)) $ + addErr (TcRnSafeImportsDisabled imp_mod_name) + + let imp_mod = mi_module iface + qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name + imp_spec = ImpDeclSpec { is_mod = imp_mod, is_qual = qual_only, + is_dloc = locA loc, is_as = qual_mod_name } + + -- filter the imports according to the import declaration + (new_imp_details, gres) <- filterImports hsc_env iface imp_spec imp_details + + -- for certain error messages, we’d like to know what could be imported + -- here, if everything were imported + potential_gres <- mkGlobalRdrEnv . snd <$> filterImports hsc_env iface imp_spec Nothing + + let gbl_env = mkGlobalRdrEnv gres + + is_hiding | Just (EverythingBut,_) <- imp_details = True + | otherwise = False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) + + hsc_env <- getTopEnv + let home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env + imv = ImportedModsVal + { imv_name = qual_mod_name + , imv_span = locA loc + , imv_is_safe = mod_safe' + , imv_is_hiding = is_hiding + , imv_all_exports = potential_gres + , imv_qualified = qual_only + } + imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) + + -- Complain if we import a deprecated module + case fromIfaceWarnings (mi_warns iface) of + WarnAll txt -> addDiagnostic (TcRnDeprecatedModule imp_mod_name txt) + _ -> return () + + -- Complain about -Wcompat-unqualified-imports violations. + warnUnqualifiedImport decl iface + + let new_imp_decl = ImportDecl + { ideclExt = ideclExt decl + , ideclName = ideclName decl + , ideclPkgQual = pkg_qual + , ideclSource = ideclSource decl + , ideclSafe = mod_safe' + , ideclQualified = ideclQualified decl + , ideclAs = ideclAs decl + , ideclImportList = new_imp_details + } + + return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) + + +-- | Rename raw package imports +renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual +renameRawPkgQual unit_env mn = \case + NoRawPkgQual -> NoPkgQual + RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) + +-- | Rename raw package imports +renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual +renamePkgQual unit_env mn mb_pkg = case mb_pkg of + Nothing -> NoPkgQual + Just pkg_fs + | Just uid <- homeUnitId <$> ue_homeUnit unit_env + , pkg_fs == fsLit "this" + -> ThisPkg uid + + | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names + -> ThisPkg uid + + | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) + -> OtherPkg uid + + | otherwise + -> OtherPkg (UnitId pkg_fs) + -- not really correct as pkg_fs is unlikely to be a valid unit-id but + -- we will report the failure later... + where + home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + + units = ue_units unit_env + + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends units + + +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: HomeUnit + -> S.Set UnitId + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportedBy + -> ImportAvails +calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = + let imp_mod = mi_module iface + imp_sem_mod= mi_semantic_module iface + orph_iface = mi_orphan (mi_final_exts iface) + has_finsts = mi_finsts (mi_final_exts iface) + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + is_sig = mi_hsc_src iface == HsigFile + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this involves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + -- + -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module + -- itself, but we DO need to include this module in 'imp_orphs' and + -- 'imp_finsts' if it defines an orphan or instance family; thus the + -- orph_iface/has_iface tests. + + deporphs = dep_orphs deps + depfinsts = dep_finsts deps + + orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $ + imp_sem_mod : deporphs + | otherwise = deporphs + + finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $ + imp_sem_mod : depfinsts + | otherwise = depfinsts + + -- Trusted packages are a lot like orphans. + trusted_pkgs | mod_safe' = dep_trusted_pkgs deps + | otherwise = S.empty + + + pkg = moduleUnit (mi_module iface) + ipkg = toUnitId pkg + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + pkg_trust_req + | isHomeUnit home_unit pkg = ptrust + | otherwise = False + + dependent_pkgs = if toUnitId pkg `S.member` other_home_units + then S.empty + else S.singleton ipkg + + direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) + else S.empty + + dep_boot_mods_map = mkModDeps (dep_boot_mods deps) + + boot_mods + -- If we are looking for a boot module, it must be HPT + | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot) + -- Now we are importing A properly, so don't go looking for + -- A.hs-boot + | isHomeUnit home_unit pkg = dep_boot_mods_map + -- There's no boot files to find in external imports + | otherwise = emptyInstalledModuleEnv + + sig_mods = + if is_sig + then moduleName imp_mod : dep_sig_mods deps + else dep_sig_mods deps + + + in ImportAvails { + imp_mods = unitModuleEnv (mi_module iface) [imported_by], + imp_orphs = orphans, + imp_finsts = finsts, + imp_sig_mods = sig_mods, + imp_direct_dep_mods = direct_mods, + imp_dep_direct_pkgs = dependent_pkgs, + imp_boot_mods = boot_mods, + + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = trusted_pkgs, + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + + +-- | Issue a warning if the user imports Data.List without either an import +-- list or `qualified`. This is part of the migration plan for the +-- `Data.List.singleton` proposal. See #17244. +warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () +warnUnqualifiedImport decl iface = + when bad_import $ do + addDiagnosticAt loc (TcRnCompatUnqualifiedImport decl) + where + mod = mi_module iface + loc = getLocA $ ideclName decl + + is_qual = isImportDeclQualified (ideclQualified decl) + has_import_list = + -- We treat a `hiding` clause as not having an import list although + -- it's not entirely clear this is the right choice. + case ideclImportList decl of + Just (Exactly, _) -> True + _ -> False + bad_import = + not is_qual + && not has_import_list + && mod `elemModuleSet` qualifiedMods + + -- Modules for which we warn if we see unqualified imports + qualifiedMods = mkModuleSet [ dATA_LIST ] + +{- +************************************************************************ +* * +\subsection{importsFromLocalDecls} +* * +************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Note [Top-level Names in Template Haskell decl quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env + Note [Looking up Exact RdrNames] in GHC.Rename.Env + +Consider a Template Haskell declaration quotation like this: + module M where + f x = h [d| f = 3 |] +When renaming the declarations inside [d| ...|], we treat the +top level binders specially in two ways + +1. We give them an Internal Name, not (as usual) an External one. + This is done by GHC.Rename.Env.newTopSrcBinder. + +2. We make them *shadow* the outer bindings. + See Note [GlobalRdrEnv shadowing] + +3. We find out whether we are inside a [d| ... |] by testing the TH + stage. This is a slight hack, because the stage field was really + meant for the type checker, and here we are not interested in the + fields of Brack, hence the error thunks in thRnBrack. +-} + +extendGlobalRdrEnvRn :: [GlobalRdrElt] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] + +extendGlobalRdrEnvRn new_gres new_fixities + = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] + do { (gbl_env, lcl_env) <- getEnvs + ; stage <- getStage + ; isGHCi <- getIsGHCi + ; let rdr_env = tcg_rdr_env gbl_env + fix_env = tcg_fix_env gbl_env + th_bndrs = getLclEnvThBndrs lcl_env + th_lvl = thLevel stage + + -- Delete new_occs from global and local envs + -- If we are in a TemplateHaskell decl bracket, + -- we are going to shadow them + -- See Note [GlobalRdrEnv shadowing] + inBracket = isBrackStage stage + + lcl_env_TH = modifyLclCtxt (\lcl_env -> lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env }) lcl_env + -- See Note [GlobalRdrEnv shadowing] + + lcl_env2 | inBracket = lcl_env_TH + | otherwise = lcl_env + + -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] + want_shadowing = isGHCi || inBracket + rdr_env1 | want_shadowing = shadowNames False rdr_env new_gres_env + | otherwise = rdr_env + + lcl_env3 = modifyLclCtxt (\lcl_env -> lcl_env { tcl_th_bndrs = extendNameEnvList th_bndrs + [ ( n, (TopLevel, th_lvl) ) + | n <- new_names ] }) lcl_env2 + + ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres + + ; let fix_env' = foldl' extend_fix_env fix_env new_gres + gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } + + ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) + ; return (gbl_env', lcl_env3) } + where + new_names = map greName new_gres + new_gres_env = mkGlobalRdrEnv new_gres + + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env gre + | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) + = extendNameEnv fix_env name (FixItem occ fi) + | otherwise + = fix_env + where + name = greName gre + occ = greOccName gre + + add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv + -- Extend the GlobalRdrEnv with a LocalDef GRE + -- If there is already a LocalDef GRE with the same OccName, + -- report an error and discard the new GRE + -- This establishes INVARIANT 1 of GlobalRdrEnvs + add_gre env gre + | not (null dups) -- Same OccName defined twice + = do { addDupDeclErr (gre :| dups); return env } + + | otherwise + = return (extendGlobalRdrEnv env gre) + where + -- See Note [Reporting duplicate local declarations] + dups = filter isBadDupGRE + $ lookupGRE env (LookupOccName (greOccName gre) (RelevantGREsFOS WantBoth)) + isBadDupGRE old_gre = isLocalGRE old_gre && greClashesWith gre old_gre + +{- Note [Fail fast on duplicate definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there are duplicate bindings for the same thing, we want to fail +fast. Having two bindings for the same thing can cause follow-on errors. +Example (test T9975a): + data Test = Test { x :: Int } + pattern Test wat = Test { x = wat } +This defines 'Test' twice. The second defn has no field-names; and then +we get an error from Test { x=wat }, saying "Test has no field 'x'". + +Easiest thing is to bale out fast on duplicate definitions, which +we do via `checkNoErrs` on `extendGlobalRdrEnvRn`. + +Note [Reporting duplicate local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a single module may not define the same OccName multiple times. This +is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the +GlobalRdrEnv we report an error if there are already duplicates in the +environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in +GHC.Types.Name.Reader), which says that for a given OccName, all the +GlobalRdrElts to which it maps must have distinct 'greName's. + +For example, the following will be rejected: + + f x = x + g x = x + f x = x -- Duplicate! + +Users are allowed to introduce new GREs with the same OccName as an imported GRE, +as disambiguation is possible through the module system, e.g.: + + module M where + import N (f) + f x = x + g x = M.f x + N.f x + +If both GREs are local, the general rule is that two GREs clash if they have +the same OccName, i.e. they share a textual name and live in the same namespace. +However, there are additional clashes due to record fields: + + - a new variable clashes with previously defined record fields + which define field selectors, + + - a new record field shadows: + + - previously defined variables, if it defines a field selector, + - previously defined record fields, unless it is a duplicate record field. + +This logic is implemented in the function 'GHC.Types.Name.Reader.greClashesWith'. + +See also Note [Skipping ambiguity errors at use sites of local declarations] in +GHC.Rename.Utils. +-} + + +{- ********************************************************************* +* * + getLocalDeclBindersd@ returns the names for an HsDecl + It's used for source code. + + *** See Note [The Naming story] in GHC.Hs.Decls **** +* * +********************************************************************* -} + +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs + -> RnM ((TcGblEnv, TcLclEnv), NameSet) +-- Get all the top-level binders bound the group *except* +-- for value bindings, which are treated separately +-- Specifically we return AvailInfo for +-- * type decls (incl constructors and record selectors) +-- * class decls (including class ops) +-- * associated types +-- * foreign imports +-- * value signatures (in hs-boot files only) + +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = binds, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = do { -- Process all type/class decls *except* family instances + ; let inst_decls = tycl_decls >>= group_instds + ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags + ; has_sel <- xopt_FieldSelectors <$> getDynFlags + ; tc_gres + <- concatMapM + (new_tc dup_fields_ok has_sel) + (tyClGroupTyClDecls tycl_decls) + ; traceRn "getLocalNonValBinders 1" (ppr tc_gres) + ; envs <- extendGlobalRdrEnvRn tc_gres fixity_env + ; restoreEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] + + -- Process all family instances + -- to bring new data constructors into scope + ; nti_gress <- mapM (new_assoc dup_fields_ok has_sel) inst_decls + + -- Finish off with value binders: + -- foreign decls and pattern synonyms for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBootOrSig + ; let val_bndrs + | is_boot = case binds of + ValBinds _ _val_binds val_sigs -> + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + [ L (l2l decl_loc) (unLoc n) + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] + _ -> panic "Non-ValBinds in hs-boot group" + | otherwise = for_hs_bndrs + ; val_gres <- mapM new_simple val_bndrs + + ; let avails = concat nti_gress ++ val_gres + new_bndrs = gresToNameSet avails `unionNameSet` + gresToNameSet tc_gres + ; traceRn "getLocalNonValBinders 2" (ppr avails) + ; envs <- extendGlobalRdrEnvRn avails fixity_env + ; return (envs, new_bndrs) } } + where + for_hs_bndrs :: [LocatedN RdrName] + for_hs_bndrs = hsForeignDeclsBinders foreign_decls + + -- the SrcSpan attached to the input should be the span of the + -- declaration, not just the name + new_simple :: LocatedN RdrName -> RnM GlobalRdrElt + new_simple rdr_name = do { nm <- newTopSrcBinder rdr_name + ; return (mkLocalVanillaGRE NoParent nm) } + + new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs + -> RnM [GlobalRdrElt] + new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances + = do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs + (LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl + ; tycon_name <- newTopSrcBinder $ l2n main_bndr + ; at_names <- mapM (newTopSrcBinder . l2n . fst) at_bndrs + ; sig_names <- mapM (newTopSrcBinder . l2n) sig_bndrs + ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds + ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds + ; mapM_ (add_dup_fld_errs flds') con_names_with_flds + ; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name + fld_env = mk_fld_env con_names_with_flds flds' + at_gres = zipWith (\ (_, at_flav) at_nm -> mkLocalTyConGRE (fmap (const tycon_name) at_flav) at_nm) + at_bndrs at_names + sig_gres = map (mkLocalVanillaGRE (ParentIs tycon_name)) sig_names + con_gres = map (mkLocalConLikeGRE (ParentIs tycon_name)) fld_env + fld_gres = mkLocalFieldGREs (ParentIs tycon_name) fld_env + sub_gres = at_gres ++ sig_gres ++ con_gres ++ fld_gres + ; traceRn "getLocalNonValBinders new_tc" $ + vcat [ text "tycon:" <+> ppr tycon_name + , text "tc_gre:" <+> ppr tc_gre + , text "sub_gres:" <+> ppr sub_gres ] + ; return $ tc_gre : sub_gres } + + -- Calculate the record field information, which feeds into the GlobalRdrElts + -- for DataCons and their fields. It's convenient to do this here where + -- we are working with a single datatype definition. + -- + -- The information we needed was all set up for us: + -- see Note [Collecting record fields in data declarations] in GHC.Hs.Utils. + mk_fld_env :: [(Name, Maybe [Located Int])] -> IntMap FieldLabel + -> [(ConLikeName, ConInfo)] + mk_fld_env names flds = + [ (DataConName con, con_info) + | (con, mb_fl_indxs) <- names + , let con_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of + Nothing -> ConHasPositionalArgs + Just [] -> ConIsNullary + Just (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ] + + new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs + -> RnM [GlobalRdrElt] + new_assoc _ _ (L _ (TyFamInstD {})) = return [] + -- type instances don't bind new names + + new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) + = new_di dup_fields_ok has_sel Nothing d + new_assoc dup_fields_ok has_sel + (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) + = do -- First, attempt to grab the name of the class from the instance. + -- This step could fail if the instance is not headed by a class, + -- such as in the following examples: + -- + -- (1) The class is headed by a bang pattern, such as in + -- `instance !Show Int` (#3811c) + -- (2) The class is headed by a type variable, such as in + -- `instance c` (#16385) + -- + -- If looking up the class name fails, then mb_cls_gre will + -- be Nothing. + mb_cls_gre <- runMaybeT $ do + -- See (1) above + L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty + -- See (2) above + MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe SameNameSpace cls_rdr + -- Assuming the previous step succeeded, process any associated data + -- family instances. If the previous step failed, bail out. + case mb_cls_gre of + Nothing + -> pure [] + Just cls_gre + -> let cls_nm = greName cls_gre + in concatMapM (new_di dup_fields_ok has_sel (Just cls_nm) . unLoc) adts + + new_di :: DuplicateRecordFields -> FieldSelectors + -> Maybe Name -- class name + -> DataFamInstDecl GhcPs + -> RnM [GlobalRdrElt] + new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) + = do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl) + ; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid + ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds + ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds + ; mapM_ (add_dup_fld_errs flds') sub_names + ; let fld_env = mk_fld_env sub_names flds' + con_gres = map (mkLocalConLikeGRE (ParentIs main_name)) fld_env + field_gres = mkLocalFieldGREs (ParentIs main_name) fld_env + -- NB: the data family name is not bound here, + -- so we don't return a GlobalRdrElt for it here! + ; return $ con_gres ++ field_gres } + + -- Add errors if a constructor has a duplicate record field. + add_dup_fld_errs :: IntMap FieldLabel + -> (Name, Maybe [Located Int]) + -> IOEnv (Env TcGblEnv TcLclEnv) () + add_dup_fld_errs all_flds (con, mb_con_flds) + | Just con_flds <- mb_con_flds + , let (_, dups) = removeDups (comparing unLoc) con_flds + = for_ dups $ \ dup_flds -> + -- Report the error at the location of the second occurrence + -- of the duplicate field. + let loc = + case dup_flds of + _ :| ( L loc _ : _) -> loc + L loc _ :| _ -> loc + dup_rdrs = fmap (nameRdrName . flSelector . (all_flds IntMap.!) . unLoc) dup_flds + in addErrAt loc $ TcRnDuplicateFieldName (RecordFieldDecl con) dup_rdrs + | otherwise + = return () + +newRecordFieldLabel :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordFieldLabel _ _ [] _ = error "newRecordFieldLabel: datatype has no constructors!" +newRecordFieldLabel dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) + = do { selName <- newTopSrcBinder $ L (l2l loc) $ field + ; return $ FieldLabel { flHasDuplicateRecordFields = dup_fields_ok + , flHasFieldSelector = has_sel + , flSelector = selName } } + where + fld_occ = rdrNameOcc fld + dc_fs = occNameFS $ nameOccName dc + field + -- Use an Exact RdrName as-is, to preserve the bindings + -- of an already renamer-resolved field and its use + -- sites. This is needed to correctly support record + -- selectors in Template Haskell. See Note [Binders in + -- Template Haskell] in "GHC.ThToHs" and Note [Looking up + -- Exact RdrNames] in "GHC.Rename.Env". + | isExact fld + = assertPpr (fieldOcc_maybe fld_occ == Just dc_fs) + (vcat [ text "newRecordFieldLabel: incorrect namespace for exact Name" <+> quotes (ppr fld) + , text "expected namespace:" <+> pprNameSpace (fieldName dc_fs) + , text " actual namespace:" <+> pprNameSpace (occNameSpace fld_occ) ]) + fld + + -- Field names produced by the parser are namespaced with VarName. + -- Here we namespace them according to the first constructor. + -- See Note [Record field namespacing] in GHC.Types.Name.Occurrence. + | otherwise + = mkRdrUnqual $ varToRecFieldOcc dc_fs fld_occ + +{- +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +************************************************************************ +* * +\subsection{Filtering imports} +* * +************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take each AvailInfo from the mi_exports of M, and make + + imp_occ_env :: OccEnv (NameEnv ImpOccItem) + +This map contains one entry for each OccName that M exports, mapping each OccName +to the following information: + + 1. the GlobalRdrElt corresponding to the OccName, + 2. whether this GlobalRdrElt was the parent in the AvailInfo we found + the OccName in. + 3. the GlobalRdrElts that were bundled together in the AvailInfo we found + this OccName in (not including the parent), + +We need (2) and (3) during the construction of the OccEnv because of associated +types and bundled pattern synonyms, respectively. +(3) is explained in Note [Importing PatternSynonyms]. + +To explain (2), consider for example: + + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } + +Here, M's exports avails are (recalling the AvailTC invariant from GHC.Types.Avail) + + C(C,T), T(T,T1,T2,T3) + +Notice that T appears *twice*, once as a child and once as a parent. From +these two exports, respectively, during construction of the imp_occ_env, we begin +by associating the following two elements with the key T: + + T -> ImpOccItem { imp_item = T, imp_bundled = [C,T] , imp_is_parent = False } + T -> ImpOccItem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +We combine these (in function 'combine' in 'mkImportOccEnv') by simply discarding +the first item, to get: + + T -> IE_ITem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +So the overall imp_occ_env is: + + C -> ImpOccItem { imp_item = C, imp_bundled = [T ], imp_is_parent = True } + T -> ImpOccItem { imp_item = T , imp_bundled = [T1,T2,T3], imp_is_parent = True } + T1 -> ImpOccItem { imp_item = T1, imp_bundled = [T1,T2,T3], imp_is_parent = False } + -- similarly for T2, T3 + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. + +Note [Importing PatternSynonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Dealing with imports], associated types can lead to the +same Name appearing twice, both as a child and once as a parent, when +constructing the imp_occ_env. The same thing can happen with pattern synonyms +if they are exported bundled with a type. + +A simplified example, based on #11959: + + {-# LANGUAGE PatternSynonyms #-} + module M (T(P), pattern P) where -- Duplicate export warning, but allowed + data T = MkT + pattern P = MkT + +Here we have T(P) and P in export_avails, and respectively construct both + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + P -> ImpOccItem { imp_item = P, imp_bundled = [] , imp_is_parent = False } + +We combine these by dropping the one with no siblings, leaving us with: + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + +That is, we simply discard the non-bundled Avail. + +Note [Importing DuplicateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In filterImports, another complicating factor is DuplicateRecordFields. +Suppose we have: + + {-# LANGUAGE DuplicateRecordFields #-} + module M (S(foo), T(foo)) where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + + module N where + import M (foo) -- this is allowed (A) + import M (S(foo)) -- this is allowed (B) + +Here M exports 'foo' at two different OccNames, with different namespaces for +the two construtors MkS and MkT. Then, when we look up 'foo' in lookup_names +for case (A), we have a variable foo but must look in all the record field +namespaces to find the two fields (and hence two different Avails). +Whereas in case (B) we reach the lookup_ie case for IEThingWith, +which looks up 'S' and then finds the unique 'foo' amongst its children. + +See T16745 for a test of this. +-} + +-- | All the 'GlobalRdrElt's associated with an 'AvailInfo'. +gresFromAvail :: HasDebugCallStack + => HscEnv -> Maybe ImportSpec -> AvailInfo -> [GlobalRdrElt] +gresFromAvail hsc_env prov avail = + [ mk_gre nm info + | nm <- availNames avail + , let info = lookupGREInfo hsc_env nm ] + where + + mk_gre n info + = case prov of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = emptyBag + , gre_info = info } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = unitBag is + , gre_info = info } + +-- | All the 'GlobalRdrElt's associated with a collection of 'AvailInfo's. +gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov) + +filterImports + :: HasDebugCallStack + => HscEnv + -> ModIface + -> ImpDeclSpec + -- ^ Import spec + -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) + -- ^ Whether this is a "hiding" import list + -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names + [GlobalRdrElt]) -- Same again, but in GRE form +filterImports hsc_env iface decl_spec Nothing + = return (Nothing, gresFromAvails hsc_env (Just imp_spec) all_avails) + where + all_avails = mi_exports iface + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + +filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) + = do -- check for errors, convert RdrNames to Names + items1 <- mapM lookup_lie import_items + + let items2 :: [(LIE GhcRn, [GlobalRdrElt])] + items2 = concat items1 + -- NB we may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) + + gres = case want_hiding of + Exactly -> + concatMap (gresFromIE decl_spec) items2 + EverythingBut -> + let hidden_names = mkNameSet $ concatMap (map greName . snd) items2 + keep n = not (n `elemNameSet` hidden_names) + all_gres = gresFromAvails hsc_env (Just hiding_spec) all_avails + in filter (keep . greName) all_gres + + return (Just (want_hiding, L l (map fst items2)), gres) + where + import_mod = mi_module iface + all_avails = mi_exports iface + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails + + -- Look up a parent (type constructor, class or data constructor) + -- in an import. + lookup_parent :: IE GhcPs -> RdrName -> IELookupM ImpOccItem + lookup_parent ie rdr = + assertPpr (not $ isVarNameSpace ns) + (vcat [ text "filterImports lookup_parent: unexpected variable" + , text "rdr:" <+> ppr rdr + , text "namespace:" <+> pprNameSpace ns ]) $ + do { xs <- lookup_names ie rdr + ; case xs of + cax :| [] -> return cax + _ -> pprPanic "filter_imports lookup_parent ambiguous" $ + vcat [ text "rdr:" <+> ppr rdr + , text "lookups:" <+> ppr (fmap imp_item xs) ] } + -- Looking up non-variables is always unambiguous, + -- as there can be at most one corresponding item + -- in the imp_occ_env. + -- See item (1) of Note [Exporting duplicate declarations] + -- in GHC.Tc.Gen.Export. + where + occ = rdrNameOcc rdr + ns = occNameSpace occ + + -- Look up a RdrName used in an import, returning multiple values if there + -- are several fields with the same name exposed by the module + lookup_names :: IE GhcPs -> RdrName -> IELookupM (NonEmpty ImpOccItem) + lookup_names ie rdr + | isQual rdr + = failLookupWith (QualImportError rdr) + | otherwise + = case lookups of + [] -> failLookupWith (BadImport ie IsNotSubordinate) + item:items -> return $ item :| items + where + lookups = concatMap nonDetNameEnvElts + $ lookupImpOccEnv (RelevantGREsFOS WantNormal) imp_occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])] + lookup_lie (L loc ieRdr) + = setSrcSpanA loc $ + do (stuff, warns) <- liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie ieRdr) + mapM_ (addTcRnDiagnostic <=< warning_msg) warns + return [ (L loc ie, gres) | (ie,gres) <- stuff ] + where + + -- Warn when importing T(..) and no children are brought in scope + warning_msg (DodgyImport n) = + pure (TcRnDodgyImports (DodgyImportsEmptyParent n)) + warning_msg MissingImportList = + pure (TcRnMissingImportList ieRdr) + warning_msg (BadImportW ie) = do + -- 'BadImportW' is only constructed below in 'handle_bad_import', in + -- the 'EverythingBut' case, so that's what we pass to + -- 'badImportItemErr'. + reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails + pure (TcRnDodgyImports (DodgyImportsHiding reason)) + warning_msg (DeprecatedExport n w) = + pure (TcRnPragmaWarning { + pragma_warning_occ = occName n + , pragma_warning_msg = w + , pragma_warning_import_mod = moduleName import_mod + , pragma_warning_defined_mod = Nothing + }) + + run_lookup :: IELookupM a -> TcRn (Maybe a) + run_lookup m = case m of + Failed err -> do + msg <- lookup_err_msg err + addErr (TcRnImportLookup msg) + return Nothing + Succeeded a -> return (Just a) + + lookup_err_msg err = case err of + BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails + IllegalImport -> pure ImportLookupIllegal + QualImportError rdr -> pure (ImportLookupQualified rdr) + + -- For each import item, we convert its RdrNames to Names, + -- and at the same time compute all the GlobalRdrElt corresponding + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- + -- Returns a list because, with DuplicateRecordFields, a naked + -- import/export of a record field can correspond to multiple + -- different GlobalRdrElts. See Note [Importing DuplicateRecordFields]. + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, [GlobalRdrElt])], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ + case ie of + IEVar _ (L l n) -> do + -- See Note [Importing DuplicateRecordFields] + xs <- lookup_names ie (ieWrappedName n) + let gres = map imp_item $ NE.toList xs + export_depr_warns + | want_hiding == Exactly + = mapMaybe mk_depr_export_warning gres + | otherwise = [] + return ( [ (IEVar Nothing (L l (replaceWrappedName n name)), [gre]) + | gre <- gres + , let name = greName gre ] + , export_depr_warns ) + + IEThingAll _ (L l tc) -> do + ImpOccItem gre child_gres _ <- lookup_parent ie $ ieWrappedName tc + let name = greName gre + imp_list_warn + + | null child_gres + -- e.g. f(..) or T(..) where T is a type synonym + = [DodgyImport gre] + + -- e.g. import M( T(..) ) + | not (is_qual decl_spec) + = [MissingImportList] + + | otherwise + = [] + + renamed_ie = IEThingAll (Nothing, noAnn) (L l (replaceWrappedName tc name)) + export_depr_warn + | want_hiding == Exactly + = maybeToList $ mk_depr_export_warning gre + -- We don't want to warn about the children as they + -- are not explicitly mentioned; the warning will + -- be emitted later on if they are used + | otherwise = [] + + return ( [(renamed_ie, gre:child_gres)] + , imp_list_warn ++ export_depr_warn) + + + IEThingAbs _ (L l tc') + | want_hiding == EverythingBut -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc = ieWrappedName tc' + tc_name = lookup_parent ie tc + dc_name = lookup_parent ie (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith (BadImport ie IsNotSubordinate) + names -> return ( [mkIEThingAbs tc' l (imp_item name) | name <- names], []) + | otherwise + -> do ImpOccItem { imp_item = gre } <- lookup_parent ie (ieWrappedName tc') + return ( [mkIEThingAbs tc' l gre] + , maybeToList $ mk_depr_export_warning gre) + + IEThingWith (deprecation, ann) ltc@(L l rdr_tc) wc rdr_ns -> do + ImpOccItem { imp_item = gre, imp_bundled = subnames } + <- lookup_parent (IEThingAbs (Nothing, noAnn) ltc) (ieWrappedName rdr_tc) + let name = greName gre + + -- Look up the children in the sub-names of the parent + -- See Note [Importing DuplicateRecordFields] + case lookupChildren subnames rdr_ns of + + Failed rdrs -> failLookupWith $ + BadImport (IEThingWith (deprecation, ann) ltc wc rdrs) IsSubordinate + -- We are trying to import T( a,b,c,d ), and failed + -- to find 'b' and 'd'. So we make up an import item + -- to report as failing, namely T( b, d ). + -- c.f. #15412 + + Succeeded childnames -> + return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' + ,gres)] + , export_depr_warns) + + where name' = replaceWrappedName rdr_tc name + childnames' = map (to_ie_post_rn . fmap greName) childnames + gres = gre : map unLoc childnames + export_depr_warns + | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres + | otherwise = [] + + _other -> failLookupWith IllegalImport + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed... + -- all of those constitute errors. + + where + mkIEThingAbs tc l gre + = (IEThingAbs (Nothing, noAnn) (L l (replaceWrappedName tc n)), [gre]) + where n = greName gre + + handle_bad_import m = catchIELookup m $ \err -> case err of + BadImport ie _ + | want_hiding == EverythingBut + -> return ([], [BadImportW ie]) + _ -> failLookupWith err + + mk_depr_export_warning gre + = DeprecatedExport name <$> mi_export_warn_fn (mi_final_exts iface) name + where + name = greName gre + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW (IE GhcPs) + | MissingImportList + | DodgyImport GlobalRdrElt + | DeprecatedExport Name (WarningTxt GhcRn) + +-- | Is this import/export item a subordinate or not? +data IsSubordinate + = IsSubordinate | IsNotSubordinate + +data IELookupError + = QualImportError RdrName + | BadImport (IE GhcPs) IsSubordinate + | IllegalImport + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err + +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] + +-- | Information associated to an 'AvailInfo' used in constructing +-- an 'OccEnv' corresponding to imports. +-- +-- See Note [Dealing with imports]. +data ImpOccItem + = ImpOccItem + { imp_item :: GlobalRdrElt + -- ^ The import item + , imp_bundled :: [GlobalRdrElt] + -- ^ Items bundled in the Avail this import item came from, + -- not including the import item itself if it is a parent. + , imp_is_parent :: Bool + -- ^ Is the import item a parent? See Note [Dealing with imports]. + } + +-- | Make an 'OccEnv' of all the imports. +-- +-- Complicated by the fact that associated data types and pattern synonyms +-- can appear twice. See Note [Dealing with imports]. +mkImportOccEnv :: HscEnv -> ImpDeclSpec -> [IfaceExport] -> OccEnv (NameEnv ImpOccItem) +mkImportOccEnv hsc_env decl_spec all_avails = + mkOccEnv_C (plusNameEnv_C combine) + [ (occ, mkNameEnv [(nm, ImpOccItem g bundled is_parent)]) + | avail <- all_avails + , let gs = gresFromAvail hsc_env (Just hiding_spec) avail + , g <- gs + , let nm = greName g + occ = greOccName g + (is_parent, bundled) = case avail of + AvailTC c _ + -> if c == nm -- (Recall the AvailTC invariant) + then ( True, case gs of { g0 : gs' | greName g0 == nm -> gs'; _ -> gs } ) + else ( False, gs ) + _ -> ( False, [] ) + ] + where + + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + -- See Note [Dealing with imports] + -- 'combine' may be called for associated data types which appear + -- twice in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + -- NB: the AvailTC can have fields as well as data constructors (#12127) + combine :: ImpOccItem -> ImpOccItem -> ImpOccItem + combine item1@(ImpOccItem { imp_item = gre1, imp_is_parent = is_parent1 }) + item2@(ImpOccItem { imp_item = gre2, imp_is_parent = is_parent2 }) + | is_parent1 || is_parent2 + , not (isRecFldGRE gre1 || isRecFldGRE gre2) -- NB: does not force GREInfo. + , let name1 = greName gre1 + name2 = greName gre2 + = assertPpr (name1 == name2) + (ppr name1 <+> ppr name2) $ + if is_parent1 + then item1 + else item2 + -- Discard C(C,T) in favour of T(T, T1, T2, T3). + + -- 'combine' may also be called for pattern synonyms which appear both + -- unassociated and associated (see Note [Importing PatternSynonyms]). + combine item1@(ImpOccItem { imp_item = c1, imp_bundled = kids1 }) + item2@(ImpOccItem { imp_item = c2, imp_bundled = kids2 }) + = assertPpr (greName c1 == greName c2 + && (not (null kids1 && null kids2))) + (ppr c1 <+> ppr c2 <+> ppr kids1 <+> ppr kids2) $ + if null kids1 + then item2 + else item1 + -- Discard standalone pattern P in favour of T(P). + +-- | Essentially like @lookupGRE env (LookupOccName occ which_gres)@, +-- but working with 'ImpOccItem's instead of 'GlobalRdrElt's. +lookupImpOccEnv :: WhichGREs GREInfo + -> OccEnv (NameEnv ImpOccItem) -> OccName -> [NameEnv ImpOccItem] +lookupImpOccEnv which_gres env occ = + mapMaybe relevant_items $ lookupOccEnv_AllNameSpaces env occ + where + is_relevant :: ImpOccItem -> Bool + is_relevant (ImpOccItem { imp_item = gre }) = + greIsRelevant which_gres (occNameSpace occ) gre + relevant_items :: NameEnv ImpOccItem -> Maybe (NameEnv ImpOccItem) + relevant_items nms + | let nms' = filterNameEnv is_relevant nms + = if isEmptyNameEnv nms' + then Nothing + else Just nms' + +{- +************************************************************************ +* * +\subsection{Import/Export Utils} +* * +************************************************************************ +-} + +-- | Given an import\/export spec, appropriately set the @gre_imp@ field +-- for the 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, [GlobalRdrElt]) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, gres) + = map set_gre_imp gres + where + is_explicit = case ie of + IEThingAll _ name -> \n -> n == lieWrappedName name + _ -> \_ -> True + prov_fn name + = ImpSpec { is_decl = decl_spec, is_item = item_spec } + where + item_spec = ImpSome { is_explicit = is_explicit name + , is_iloc = locA loc } + set_gre_imp gre@( GRE { gre_name = nm } ) + = gre { gre_imp = unitBag $ prov_fn nm } + +{- +Note [Children for duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the module + + {-# LANGUAGE DuplicateRecordFields #-} + module M (F(foo, MkFInt, MkFBool)) where + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool } + +The `foo` in the export list refers to *both* selectors! For this +reason, lookupChildren builds an environment that maps the FastString +to a list of items, rather than a single item. +-} + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add gre env = case greParent gre of + ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre + NoParent -> env + +findChildren :: NameEnv [a] -> Name -> [a] +findChildren env n = lookupNameEnv env n `orElse` [] + +lookupChildren :: [GlobalRdrElt] + -> [LIEWrappedName GhcPs] + -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed + [LocatedA GlobalRdrElt] +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items + | null fails + = Succeeded (concat oks) + -- This 'fmap concat' trickily applies concat to the /second/ component + -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]]) + | otherwise + = Failed fails + where + mb_xs = map doOne rdr_items + fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] + oks = [ ok | Succeeded ok <- mb_xs ] + oks :: [[LocatedA GlobalRdrElt]] + + doOne item@(L l r) + = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of + Just [g] + | not $ isRecFldGRE g + -> Succeeded [L l g] + Just gs + | all isRecFldGRE gs + -> Succeeded $ map (L l) gs + _ -> Failed item + + -- See Note [Children for duplicate record fields] + kid_env = extendFsEnvList_C (++) emptyFsEnv + [(occNameFS (occName x), [x]) | x <- all_kids] + + +------------------------------- + +{- +********************************************************* +* * +\subsection{Unused names} +* * +********************************************************* +-} + +reportUnusedNames :: TcGblEnv -> HscSource -> RnM () +reportUnusedNames gbl_env hsc_src + = do { keep <- readTcRef (tcg_keep gbl_env) + ; traceRn "RUN" (ppr (tcg_dus gbl_env)) + ; warnUnusedImportDecls gbl_env hsc_src + ; warnUnusedTopBinds $ unused_locals keep + ; warnMissingSignatures gbl_env + ; warnMissingKindSignatures gbl_env } + where + used_names :: NameSet -> NameSet + used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + kids_env = mkChildEnv defined_names + -- This is done in mkExports too; duplicated work + + gre_is_used :: NameSet -> GlobalRdrElt -> Bool + gre_is_used used_names gre0 + = name `elemNameSet` used_names + || any (\ gre -> greName gre `elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + where + name = greName gre0 + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily + unused_locals :: NameSet -> [GlobalRdrElt] + unused_locals keep = + let -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names + _defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used (used_names keep)) defined_names + + in filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre + && isExternalName (greName gre) + +{- ********************************************************************* +* * + Missing signatures +* * +********************************************************************* -} + +{- +Note [Missing signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There are four warning flags in play: + + * -Wmissing-exported-signatures + Warn about any exported top-level function/value without a type signature. + Does not include pattern synonyms. + + * -Wmissing-signatures + Warn about any top-level function/value without a type signature. Does not + include pattern synonyms. Takes priority over -Wmissing-exported-signatures. + + * -Wmissing-exported-pattern-synonym-signatures + Warn about any exported pattern synonym without a type signature. + + * -Wmissing-pattern-synonym-signatures + Warn about any pattern synonym without a type signature. Takes priority over + -Wmissing-exported-pattern-synonym-signatures. + +-} + +-- | Warn the user about top level binders that lack type signatures. +-- Called /after/ type inference, so that we can report the +-- inferred type of the function +warnMissingSignatures :: TcGblEnv -> RnM () +warnMissingSignatures gbl_env + = do { let exports = availsToNameSet (tcg_exports gbl_env) + sig_ns = tcg_sigs gbl_env + -- We use sig_ns to exclude top-level bindings that are generated by GHC + binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env + pat_syns = tcg_patsyns gbl_env + + not_ghc_generated :: Name -> Bool + not_ghc_generated name = name `elemNameSet` sig_ns + + add_binding_warn :: Id -> RnM () + add_binding_warn id = + when (not_ghc_generated name) $ + do { env <- liftZonkM $ tcInitTidyEnv -- Why not use emptyTidyEnv? + ; let (_, ty) = tidyOpenType env (idType id) + missing = MissingTopLevelBindingSig name ty + diag = TcRnMissingSignature missing exported + ; addDiagnosticAt (getSrcSpan name) diag } + where + name = idName id + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + add_patsyn_warn :: PatSyn -> RnM () + add_patsyn_warn ps = + when (not_ghc_generated name) $ + addDiagnosticAt (getSrcSpan name) + (TcRnMissingSignature missing exported) + where + name = patSynName ps + missing = MissingPatSynSig ps + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + -- Warn about missing signatures + -- Do this only when we have a type to offer + -- See Note [Missing signatures] + ; mapM_ add_binding_warn binds + ; mapM_ add_patsyn_warn pat_syns + } + +-- | Warn the user about tycons that lack kind signatures. +-- Called /after/ type (and kind) inference, so that we can report the +-- inferred kinds. +warnMissingKindSignatures :: TcGblEnv -> RnM () +warnMissingKindSignatures gbl_env + = do { cusks_enabled <- xoptM LangExt.CUSKs + ; mapM_ (add_ty_warn cusks_enabled) tcs + } + where + tcs = tcg_tcs gbl_env + ksig_ns = tcg_ksigs gbl_env + exports = availsToNameSet (tcg_exports gbl_env) + + has_kind_signature :: Name -> Bool + has_kind_signature name = name `elemNameSet` ksig_ns + + add_ty_warn :: Bool -> TyCon -> RnM () + add_ty_warn cusks_enabled tyCon = + when (has_kind_signature name) $ + addDiagnosticAt (getSrcSpan name) diag + where + name = tyConName tyCon + diag = TcRnMissingSignature missing exported + missing = MissingTyConKindSig tyCon cusks_enabled + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + +{- +********************************************************* +* * +\subsection{Unused imports} +* * +********************************************************* + +This code finds which import declarations are unused. The +specification and implementation notes are here: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports + +See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader +-} + +type ImportDeclUsage + = ( LImportDecl GhcRn -- The import declaration + , [GlobalRdrElt] -- What *is* used (normalised) + , [Name] ) -- What is imported but *not* used + +warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () +warnUnusedImportDecls gbl_env hsc_src + = do { uses <- readMutVar (tcg_used_gres gbl_env) + ; let user_imports = filterOut + (ideclImplicit . ideclExt . unLoc) + (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones + rdr_env = tcg_rdr_env gbl_env + + ; let usage :: [ImportDeclUsage] + usage = findImportUsage user_imports uses + + ; traceRn "warnUnusedImportDecls" $ + (vcat [ text "Uses:" <+> ppr uses + , text "Import usage" <+> ppr usage]) + + ; mapM_ (warnUnusedImport rdr_env) usage + + ; whenGOptM Opt_D_dump_minimal_imports $ + printMinimalImports hsc_src usage } + +findImportUsage :: [LImportDecl GhcRn] + -> [GlobalRdrElt] + -> [ImportDeclUsage] + +findImportUsage imports used_gres + = map unused_decl imports + where + import_usage :: ImportMap + import_usage = mkImportMap used_gres + + unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) + unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) + = (decl, used_gres, nameSetElemsStable unused_imps) + where + used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage + -- srcSpanEnd: see Note [The ImportMap] + `orElse` [] + + used_names = mkNameSet (map greName used_gres) + used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) + + unused_imps -- Not trivial; see eg #7454 + = case imps of + Just (Exactly, L _ imp_ies) -> + foldr (add_unused . unLoc) emptyNameSet imp_ies + _other -> emptyNameSet -- No explicit import list => no unused-name list + + add_unused :: IE GhcRn -> NameSet -> NameSet + add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc + add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc + add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc + add_unused (IEThingWith _ p wc ns) acc = + add_wc_all (add_unused_with pn xs acc) + where pn = lieWrappedName p + xs = map lieWrappedName ns + add_wc_all = case wc of + NoIEWildcard -> id + IEWildcard _ -> add_unused_all pn + add_unused _ acc = acc + + add_unused_name n acc + | n `elemNameSet` used_names = acc + | otherwise = acc `extendNameSet` n + add_unused_all n acc + | n `elemNameSet` used_names = acc + | n `elemNameSet` used_parents = acc + | otherwise = acc `extendNameSet` n + add_unused_with p ns acc + | all (`elemNameSet` acc1) ns = add_unused_name p acc1 + | otherwise = acc1 + where + acc1 = foldr add_unused_name acc ns + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence the two cases in add_unused_with. + + +{- Note [The ImportMap] +~~~~~~~~~~~~~~~~~~~~~~~ +The ImportMap is a short-lived intermediate data structure records, for +each import declaration, what stuff brought into scope by that +declaration is actually used in the module. + +The SrcLoc is the location of the END of a particular 'import' +declaration. Why *END*? Because we don't want to get confused +by the implicit Prelude import. Consider (#7476) the module + import Foo( foo ) + main = print foo +There is an implicit 'import Prelude(print)', and it gets a SrcSpan +of line 1:1 (just the point, not a span). If we use the *START* of +the SrcSpan to identify the import decl, we'll confuse the implicit +import Prelude with the explicit 'import Foo'. So we use the END. +It's just a cheap hack; we could equally well use the Span too. + +The [GlobalRdrElt] are the things imported from that decl. +-} + +type ImportMap = Map RealSrcLoc [GlobalRdrElt] -- See [The ImportMap] + -- If loc :-> gres, then + -- 'loc' = the end loc of the bestImport of each GRE in 'gres' + +mkImportMap :: [GlobalRdrElt] -> ImportMap +-- For each of a list of used GREs, find all the import decls that brought +-- it into scope; choose one of them (bestImport), and record +-- the RdrName in that import decl's entry in the ImportMap +mkImportMap gres + = foldr add_one Map.empty gres + where + add_one gre@(GRE { gre_imp = imp_specs }) imp_map = + case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of + -- For srcSpanEnd see Note [The ImportMap] + RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map + UnhelpfulLoc _ -> imp_map + where + best_imp_spec = + case bagToList imp_specs of + [] -> pprPanic "mkImportMap: GRE with no ImportSpecs" (ppr gre) + is:iss -> bestImport (is NE.:| iss) + add _ gres = gre : gres + +warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () +warnUnusedImport rdr_env (L loc decl, used, unused) + + -- Do not warn for 'import M()' + | Just (Exactly, L _ []) <- ideclImportList decl + = return () + + -- Note [Do not warn about Prelude hiding] + | Just (EverythingBut, L _ hides) <- ideclImportList decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () + + -- Nothing used; drop entire declaration + | null used + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl UnusedImportNone) + + -- Everything imported is used; nop + | null unused + = return () + + -- Only one import is unused, with `SrcSpan` covering only the unused item instead of + -- the whole import statement + | Just (_, L _ imports) <- ideclImportList decl + , length unused == 1 + , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + + -- Some imports are unused + | otherwise + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + + where + -- In warning message, pretty-print identifiers unqualified unconditionally + -- to improve the consistent for ambiguous/unambiguous identifiers. + -- See trac#14881. + possible_field n = + case lookupGRE_Name rdr_env n of + Just (GRE { gre_par = par, gre_info = IAmRecField info }) -> + let fld_occ :: OccName + fld_occ = nameOccName $ flSelector $ recFieldLabel info + in UnusedImportNameRecField par fld_occ + _ -> UnusedImportNameRegular n + + -- Print unused names in a deterministic (lexicographic) order + sort_unused :: [UnusedImportName] + sort_unused = fmap possible_field $ + sortBy (comparing nameOccName) unused + +{- +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (#9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To print the minimal imports we walk over the user-supplied import +decls, and simply trim their import lists. NB that + + * We do *not* change the 'qualified' or 'as' parts! + + * We do not discard a decl altogether; we might need instances + from it. Instead we just trim to an empty import list +-} + +getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] +getMinimalImports ie_decls + = do { rdr_env <- getGlobalRdrEnv + ; fmap combine $ mapM (mk_minimal rdr_env) ie_decls } + where + mk_minimal rdr_env (L l decl, used_gres, unused) + | null unused + , Just (Exactly, _) <- ideclImportList decl + = return (L l decl) + | otherwise + = do { let ImportDecl { ideclName = L _ mod_name + , ideclSource = is_boot + , ideclPkgQual = pkg_qual } = decl + ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual + ; let used_avails = gresToAvailInfo used_gres + ; lies <- map (L l) <$> concatMapM (to_ie rdr_env iface) used_avails + ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } + where + doc = text "Compute minimal imports for" <+> ppr decl + + to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn] + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie rdr_env _ (Avail c) -- Note [Overloaded field import] + = do { let + gre = expectJust "getMinimalImports Avail" $ lookupGRE_Name rdr_env c + ; return $ [IEVar Nothing (to_ie_post_rn $ noLocA $ greName gre)] } + to_ie _ _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else + | availExportsDecl avail + = return [IEThingAbs (Nothing, noAnn) (to_ie_post_rn $ noLocA n)] + to_ie rdr_env iface (AvailTC n cs) = + case [ xs | avail@(AvailTC x xs) <- mi_exports iface + , x == n + , availExportsDecl avail -- Note [Partial export] + ] of + [xs] + | all_used xs + -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n)] + | otherwise + -> do { let ns_gres = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs + ns = map greName ns_gres + ; return [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] } + -- Note [Overloaded field import] + _other + -> do { let infos = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs + (ns_gres,fs_gres) = classifyGREs infos + ns = map greName (ns_gres ++ fs_gres) + fs = map fieldGREInfo fs_gres + ; return $ + if all_non_overloaded fs + then map (IEVar Nothing . to_ie_post_rn_var . noLocA) ns + else [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] } + where + + all_used avail_cs = all (`elem` cs) avail_cs + + all_non_overloaded = all (not . flIsOverloaded . recFieldLabel) + + combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] + combine = map merge . NE.groupAllWith getKey + + getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName) + getKey decl = + ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first) + , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad) + , unLoc . ideclName $ idecl -- Module Name + ) + where + idecl :: ImportDecl GhcRn + idecl = unLoc decl + + merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn + merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) }) + where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls + +classifyGREs :: [GlobalRdrElt] -> ([GlobalRdrElt], [FieldGlobalRdrElt]) +classifyGREs = partition (not . isRecFldGRE) + +printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] +printMinimalImports hsc_src imports_w_usage + = do { imports' <- getMinimalImports imports_w_usage + ; this_mod <- getModule + ; dflags <- getDynFlags + ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> + printForUser dflags h neverQualify AllTheWay (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 + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! + } + where + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d basefn + | otherwise = basefn + where + suffix = case hsc_src of + HsBootFile -> ".imports-boot" + HsSrcFile -> ".imports" + HsigFile -> ".imports" + basefn = moduleNameString (moduleName this_mod) ++ suffix + + +to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn +to_ie_post_rn_var (L l n) + | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n)) + | otherwise = L l (IEName noExtField (L (la2na l) n)) + + +to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn +to_ie_post_rn (L l n) + | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n)) + | otherwise = L l (IEName noExtField (L (la2na l) n)) + where occ = occName n + +{- +Note [Partial export] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + module A( op ) where + class C a where + op :: a -> a + + module B where + import A + f = ..op... + +Then the minimal import for module B is + import A( op ) +not + import A( C( op ) ) +which we would usually generate if C was exported from B. Hence +the availExportsDecl test when deciding what to generate. + + +Note [Overloaded field import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the other hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + data T = MkT { foo :: Int } + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( T(foo) ) +because when DuplicateRecordFields is enabled, field selectors are +not in scope without their enclosing datatype. + +On the third hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + pattern MkT { foo } = Just foo + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( foo ) +because foo doesn't have a parent. This might actually be ambiguous if A +exports another field called foo, but there is no good answer to return and this +is a very obscure corner, so it seems to be the best we can do. See +DRFPatSynExport for a test of this. + + +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +badImportItemErr + :: ModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinate + -> [AvailInfo] + -> TcRn ImportLookupReason +badImportItemErr iface decl_spec ie sub avails = do + patsyns_enabled <- xoptM LangExt.PatternSynonyms + dflags <- getDynFlags + hsc_env <- getTopEnv + let rdr_env = mkGlobalRdrEnv + $ gresFromAvails hsc_env (Just imp_spec) all_avails + pure (ImportLookupBad (importErrorKind dflags rdr_env) iface decl_spec ie patsyns_enabled) + where + importErrorKind dflags rdr_env + | any checkIfTyCon avails = case sub of + IsNotSubordinate -> BadImportAvailTyCon + IsSubordinate -> BadImportNotExportedSubordinates unavailableChildren + | any checkIfVarName avails = BadImportAvailVar + | Just con <- find checkIfDataCon avails = BadImportAvailDataCon (availOccName con) + | otherwise = BadImportNotExported suggs + where + suggs = similar_suggs ++ fieldSelectorSuggestions rdr_env rdr + similar_names = + similarNameSuggestions (Unbound.LF WL_Anything WL_Global) + dflags rdr_env emptyLocalRdrEnv rdr + similar_suggs = + case NE.nonEmpty $ mapMaybe imported_item $ similar_names of + Just similar -> [ SuggestSimilarNames rdr similar ] + Nothing -> [ ] + + -- Only keep imported items, and set the "HowInScope" to + -- "Nothing" to avoid printing "imported from..." in the suggestion + -- error message. + imported_item (SimilarRdrName rdr_name (Just (ImportedBy {}))) + = Just (SimilarRdrName rdr_name Nothing) + imported_item _ = Nothing + + checkIfDataCon = checkIfAvailMatches isDataConName + checkIfTyCon = checkIfAvailMatches isTyConName + checkIfVarName = + \case + AvailTC{} -> False + Avail n -> importedFS == occNameFS (occName n) + && (isVarOcc <||> isFieldOcc) (occName n) + checkIfAvailMatches namePred = + \case + AvailTC _ ns -> + case find (\n -> importedFS == occNameFS (occName n)) ns of + Just n -> namePred n + Nothing -> False + Avail{} -> False + availOccName = occName . availName + rdr = ieName ie + importedFS = occNameFS $ rdrNameOcc rdr + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + all_avails = mi_exports iface + unavailableChildren = case ie of + IEThingWith _ _ _ ns -> map (rdrNameOcc . ieWrappedName . unLoc) ns + _ -> panic "importedChildren failed pattern match: no children" + +addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () +addDupDeclErr gres@(gre :| _) + -- Report the error at the later location + = addErrAt (getSrcSpan (NE.last sorted_names)) $ (TcRnDuplicateDecls (greOccName gre) sorted_names) + where + sorted_names = + NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) + (fmap greName gres) + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form +-- +-- We also allow type constructor names, which are defined by "type data" +-- declarations. See Note [Type data declarations] in GHC.Rename.Module. + +checkConName :: RdrName -> TcRn () +checkConName name + = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) 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 @@ -1,3 +1,4 @@ + {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,7 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} - +{-# LANGUAGE MultiWayIf #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -46,7 +47,7 @@ import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Zonk ( hsOverLitName ) +import GHC.Tc.Utils.TcMType ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames @@ -56,33 +57,35 @@ , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) import GHC.Rename.HsType import GHC.Builtin.Names -import GHC.Types.Avail ( greNameMangledName ) -import GHC.Types.Error + import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader +import GHC.Types.Unique.Set + import GHC.Types.Basic import GHC.Types.SourceText import GHC.Utils.Misc +import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) +import GHC.Types.GREInfo ( ConInfo(..), conInfoFields ) import GHC.Builtin.Types ( nilDataCon ) import GHC.Core.DataCon -import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( when, ap, guard, unless ) +import Control.Monad ( when, ap, guard ) import Data.Foldable +import Data.Function ( on ) import Data.Functor.Identity ( Identity (..) ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio -import GHC.Types.FieldLabel (DuplicateRecordFields(..)) -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + {- ********************************************************* * * @@ -639,17 +642,28 @@ } where check_lang_exts :: RnM () - check_lang_exts = do - scoped_tyvars <- xoptM LangExt.ScopedTypeVariables - type_app <- xoptM LangExt.TypeApplications - unless (scoped_tyvars && type_app) $ - case listToMaybe tyargs of - Nothing -> pure () - Just tyarg -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal visible type application in a pattern:" - <+> quotes (ppr tyarg)) - 2 (text "Both ScopedTypeVariables and TypeApplications are" - <+> text "required to use this feature") + check_lang_exts = + for_ (listToMaybe tyargs) $ \ arg -> + do { type_abs <- xoptM LangExt.TypeAbstractions + ; type_app <- xoptM LangExt.TypeApplications + ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables + ; if | type_abs + -> return () + + -- As per [GHC Proposal 604](https://github.com/ghc-proposals/ghc-proposals/pull/604/), + -- we allow type applications in constructor patterns when -XTypeApplications and + -- -XScopedTypeVariables are both enabled, but we emit a warning when doing so. + -- + -- This warning is scheduled to become an error in GHC 9.12, in + -- which case we will get the usual error (below), + -- which suggests enabling -XTypeAbstractions. + | type_app && scoped_tvs + -> addDiagnostic TcRnDeprecatedInvisTyArgInConPat + + | otherwise + -> addErrTc $ TcRnTypeApplicationsDisabled (TypeApplicationInPattern arg) + } + rnConPatTyArg (HsConPatTyArg at t) = do t' <- liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t return (HsConPatTyArg at t') @@ -773,29 +787,30 @@ mb_con = case ctxt of HsRecFieldCon con -> Just con HsRecFieldPat con -> Just con - _ {- update -} -> Nothing + HsRecFieldUpd -> Nothing rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg) -> RnM (LHsRecField GhcRn (LocatedA arg)) rn_fld pun_ok parent (L l (HsFieldBind - { hfbLHS = - (L loc (FieldOcc _ (L ll lbl))) + { hfbLHS = L loc (FieldOcc _ (L ll lbl)) , hfbRHS = arg - , hfbPun = pun })) + , hfbPun = pun })) = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl + ; let arg_rdr = mkRdrUnqual $ recFieldToVarOcc $ occName sel + -- Discard any module qualifier (#11662) ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) } + then do { checkErr pun_ok $ + TcRnIllegalFieldPunning (L (locA loc) arg_rdr) + ; return $ L (l2l loc) $ + mk_arg (locA loc) arg_rdr } else return arg - ; return (L l (HsFieldBind - { hfbAnn = noAnn - , hfbLHS = (L loc (FieldOcc sel (L ll lbl))) - , hfbRHS = arg' - , hfbPun = pun })) } - + ; return $ L l $ + HsFieldBind + { hfbAnn = noAnn + , hfbLHS = L loc (FieldOcc sel (L ll arg_rdr)) + , hfbRHS = arg' + , hfbPun = pun } } rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an @@ -811,8 +826,8 @@ do { dd_flag <- xoptM LangExt.RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) ; (rdr_env, lcl_env) <- getRdrEnvs - ; con_fields <- lookupConstructorFields con - ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con)) + ; conInfo <- lookupConstructorInfo con + ; when (conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con)) ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) -- For constructor uses (but not patterns) @@ -822,28 +837,30 @@ -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env - (dot_dot_fields, dot_dot_gres) - = unzip [ (fl, gre) - | fl <- con_fields - , let lbl = mkVarOccFS (field_label $ flLabel fl) - , not (lbl `elemOccSet` present_flds) - , Just gre <- [lookupGRE_FieldLabel rdr_env fl] - -- Check selector is in scope - , case ctxt of - HsRecFieldCon {} -> arg_in_scope lbl - _other -> True ] + (dot_dot_fields, dot_dot_gres) = + unzip [ (fl, gre) + | fl <- conInfoFields conInfo + , let lbl = recFieldToVarOcc $ occName $ flSelector fl + , not (lbl `elemOccSet` present_flds) + , Just gre <- [lookupGRE_FieldLabel rdr_env fl] + -- Check selector is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope lbl + _other -> True ] - ; addUsedGREs dot_dot_gres + ; addUsedGREs NoDeprecationWarnings dot_dot_gres ; let locn = noAnnSrcSpan loc ; return [ L (noAnnSrcSpan loc) (HsFieldBind { hfbAnn = noAnn , hfbLHS = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) , hfbRHS = L locn (mk_arg loc arg_rdr) - , hfbPun = False }) + , hfbPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl - , let arg_rdr = mkVarUnqual (field_label $ flLabel fl) ] } + arg_rdr = mkRdrUnqual + $ recFieldToVarOcc + $ nameOccName sel ] } rn_dotdot _dotdot _mb_con _flds = return [] @@ -855,67 +872,102 @@ -- Each list represents a RdrName that occurred more than once -- (the list contains all occurrences) -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldLbls flds) - - --- NB: Consider this: --- module Foo where { data R = R { fld :: Int } } --- module Odd where { import Foo; fld x = x { fld = 3 } } --- Arguably this should work, because the reference to 'fld' is --- unambiguous because there is only one field id 'fld' in scope. --- But currently it's rejected. + (_, dup_flds) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) (getFieldLbls flds) + -- See the same duplicate handling logic in rnHsRecUpdFields below for further context. +-- | Rename a regular (non-overloaded) record field update, +-- disambiguating the fields if necessary. rnHsRecUpdFields - :: [LHsRecUpdField GhcPs] - -> RnM ([LHsRecUpdField GhcRn], FreeVars) + :: [LHsRecUpdField GhcPs GhcPs] + -> RnM (XLHsRecUpdLabels GhcRn, [LHsRecUpdField GhcRn GhcRn], FreeVars) rnHsRecUpdFields flds - = do { pun_ok <- xoptM LangExt.NamedFieldPuns - ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags - ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds - ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds + = do { pun_ok <- xoptM LangExt.NamedFieldPuns - -- Check for an empty record update e {} + -- Check for an empty record update: e {} -- NB: don't complain about e { .. }, because rn_dotdot has done that already - ; when (null flds) $ addErr TcRnEmptyRecordUpdate + ; case flds of + { [] -> failWithTc TcRnEmptyRecordUpdate + ; fld:other_flds -> + do { let dup_lbls :: [NE.NonEmpty RdrName] + (_, dup_lbls) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) + (fmap (unLoc . getFieldUpdLbl) flds) + -- NB: we compare using the underlying field label FastString, + -- in order to catch duplicates involving qualified names, + -- as in the record update `r { fld = x, Mod.fld = y }`. + -- See #21959. + -- Note that this test doesn't correctly handle exact Names, but those + -- aren't handled properly by the rest of the compiler anyway. See #22122. + ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_lbls - ; return (flds1, plusFVs fvss) } - where - rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs - -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f - , hfbRHS = arg - , hfbPun = pun })) - = do { let lbl = rdrNameAmbiguousFieldOcc f - ; mb_sel <- setSrcSpanA loc $ - -- Defer renaming of overloaded fields to the typechecker - -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - lookupRecFieldOcc_update dup_fields_ok lbl - ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (l2l loc) (HsVar noExtField - (L (l2l loc) arg_rdr))) } - else return arg - ; (arg'', fvs) <- rnLExpr arg' + -- See Note [Disambiguating record updates] + ; possible_parents <- lookupRecUpdFields (fld NE.:| other_flds) + ; let mb_unambig_lbls :: Maybe [FieldLabel] + fvs :: FreeVars + (mb_unambig_lbls, fvs) = + case possible_parents of + RnRecUpdParent { rnRecUpdLabels = gres } NE.:| [] + | let lbls = map fieldGRELabel $ NE.toList gres + -> ( Just lbls, mkFVs $ map flSelector lbls) + _ -> ( Nothing + , plusFVs $ map (plusFVs . map pat_syn_free_vars . NE.toList . rnRecUpdLabels) + $ NE.toList possible_parents + -- See Note [Using PatSyn FreeVars] + ) - ; let (lbl', fvs') = case mb_sel of - UnambiguousGre gname -> let sel_name = greNameMangledName gname - in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name) - AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs) + -- Rename each field. + ; (upd_flds, fvs') <- rn_flds pun_ok mb_unambig_lbls flds + ; let all_fvs = fvs `plusFV` fvs' + ; return (possible_parents, upd_flds, all_fvs) } } } - ; return (L l (HsFieldBind { hfbAnn = noAnn - , hfbLHS = L loc lbl' - , hfbRHS = arg'' - , hfbPun = pun }), fvs') } + where - dup_flds :: [NE.NonEmpty RdrName] - -- Each list represents a RdrName that occurred more than once - -- (the list contains all occurrences) - -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldUpdLbls flds) + -- For an ambiguous record update involving pattern synonym record fields, + -- we must add all the possibly-relevant field selector names to ensure that + -- we typecheck the record update **after** we typecheck the pattern synonym + -- definition. See Note [Using PatSyn FreeVars]. + pat_syn_free_vars :: FieldGlobalRdrElt -> FreeVars + pat_syn_free_vars (GRE { gre_info = info }) + | IAmRecField fld_info <- info + , RecFieldInfo { recFieldLabel = fl, recFieldCons = cons } <- fld_info + , uniqSetAny is_PS cons + = unitFV (flSelector fl) + pat_syn_free_vars _ + = emptyFVs + is_PS :: ConLikeName -> Bool + is_PS (PatSynName {}) = True + is_PS (DataConName {}) = False + rn_flds :: Bool -> Maybe [FieldLabel] + -> [LHsRecUpdField GhcPs GhcPs] + -> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars) + rn_flds _ _ [] = return ([], emptyFVs) + rn_flds pun_ok mb_unambig_lbls + ((L l (HsFieldBind { hfbLHS = L loc f + , hfbRHS = arg + , hfbPun = pun })):flds) + = do { let lbl = ambiguousFieldOccRdrName f + ; (arg' :: LHsExpr GhcPs) <- if pun + then do { setSrcSpanA loc $ + checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) } + else return arg + ; (arg'', fvs) <- rnLExpr arg' + ; let lbl' :: AmbiguousFieldOcc GhcRn + lbl' = case mb_unambig_lbls of + { Just (fl:_) -> + let sel_name = flSelector fl + in Unambiguous sel_name (L (l2l loc) lbl) + ; _ -> Ambiguous noExtField (L (l2l loc) lbl) } + fld' :: LHsRecUpdField GhcRn GhcRn + fld' = L l (HsFieldBind { hfbAnn = noAnn + , hfbLHS = L loc lbl' + , hfbRHS = arg'' + , hfbPun = pun }) + ; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds + ; return (fld' : flds', fvs `plusFV` fvs') } getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (hsRecFieldSel . unLoc) flds @@ -924,9 +976,6 @@ getFieldLbls flds = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds -getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds - needFlagDotDot :: HsRecFieldContext -> TcRnMessage needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart @@ -938,7 +987,59 @@ toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern n toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate -{- +{- Note [Disambiguating record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the -XDuplicateRecordFields extension is used, to rename and typecheck +a non-overloaded record update, we might need to disambiguate the field labels. + +Consider the following definitions: + + {-# LANGUAGE DuplicateRecordFields #-} + + data R = MkR1 { fld1 :: Int, fld2 :: Char } + | MKR2 { fld1 :: Int, fld2 :: Char, fld3 :: Bool } + data S = MkS1 { fld1 :: Int } | MkS2 { fld2 :: Char } + +In a record update, the `lookupRecUpdFields` function tries to determine +the parent datatype by computing the parents (TyCon/PatSyn) which have +at least one constructor (DataCon/PatSyn) with all of the fields. + +For example, in the (non-overloaded) record update + + r { fld1 = 3, fld2 = 'x' } + +only the TyCon R contains at least one DataCon which has both of the fields +being updated: in this case, MkR1 and MkR2 have both of the updated fields. +The TyCon S also has both fields fld1 and fld2, but no single constructor +has both of those fields, so S is not a valid parent for this record update. + +Note that this check is namespace-aware, so that a record update such as + + import qualified M ( R (fld1, fld2) ) + f r = r { M.fld1 = 3 } + +is unambiguous, as only R contains the field fld1 in the M namespace. +(See however #22122 for issues relating to the usage of exact Names in +record fields.) + +See also Note [Type-directed record disambiguation] in GHC.Tc.Gen.Expr. + +Note [Using PatSyn FreeVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are disambiguating a non-overloaded record update, as per +Note [Disambiguating record updates], and have determined that this +record update might involve pattern synonym record fields, it is important +to declare usage of all these pattern synonyms record fields in the returned +FreeVars of rnHsRecUpdFields. This ensures that the typechecker sees +that the typechecking of the record update depends on the typechecking +of the pattern synonym, and typechecks the pattern synonyms first. +Not doing so caused #21898. + +Note that this can be removed once GHC proposal #366 is implemented, +as we will be able to fully disambiguate the record update in the renamer, +and can immediately declare the correct used FreeVars instead of having +to over-estimate in case of ambiguity. + ************************************************************************ * * \subsubsection{Literals} 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 @@ -44,7 +44,7 @@ import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Utils.Logger import GHC.Utils.Panic @@ -62,7 +62,7 @@ , tcTopSpliceExpr ) -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) @@ -78,15 +78,10 @@ -} -- Check that -XTemplateHaskellQuotes is enabled and available -checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM () +checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM () checkForTemplateHaskellQuotes e = - do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes - ; unless thQuotesEnabled $ - failWith ( mkTcRnUnknownMessage $ mkPlainError noHints $ vcat - [ text "Syntax error on" <+> ppr e - , text ("Perhaps you intended to use TemplateHaskell" - ++ " or TemplateHaskellQuotes") ] ) - } + unlessXOptM LangExt.TemplateHaskellQuotes $ + failWith $ thSyntaxError $ IllegalTHQuotes e rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body @@ -97,13 +92,15 @@ ; cur_stage <- getStage ; case cur_stage of { Splice Typed -> return () - ; Splice Untyped -> failWithTc illegalTypedBracket + ; Splice Untyped -> failWithTc $ thSyntaxError + $ MismatchedSpliceType Untyped IsBracket ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" (ppr e) ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket + ; Brack {} -> failWithTc $ thSyntaxError + $ NestedTHBrackets } -- Brackets are desugared to code that mentions the TH package @@ -124,14 +121,16 @@ -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc illegalUntypedBracket + { Splice Typed -> failWithTc $ thSyntaxError + $ MismatchedSpliceType Typed IsBracket ; Splice Untyped -> return () ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" (ppr e) ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket + ; Brack {} -> failWithTc $ thSyntaxError + $ NestedTHBrackets } -- Brackets are desugared to code that mentions the TH package @@ -169,8 +168,8 @@ -> do { traceRn "rn_utbracket VarBr" (ppr name <+> ppr bind_lvl <+> ppr outer_stage) - ; checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr br) } + ; checkTc (thLevel outer_stage + 1 == bind_lvl) $ + TcRnTHError $ THNameError $ QuotedNameWrongStage br } } } ; return (VarBr x flg (noLocA name), unitFV name) } @@ -232,26 +231,6 @@ = hang (text "In the Template Haskell quotation") 2 (ppr br_body) -illegalBracket :: TcRnMessage -illegalBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Template Haskell brackets cannot be nested" <+> - text "(without intervening splices)" - -illegalTypedBracket :: TcRnMessage -illegalTypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Typed brackets may only appear in typed splices." - -illegalUntypedBracket :: TcRnMessage -illegalUntypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Untyped brackets may only appear in untyped splices." - -quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage -quotedNameStageErr br - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [ text "Stage error: the non-top-level quoted name" <+> ppr br - , text "must be used at the same stage at which it is bound" ] - - {- ********************************************************* * * @@ -299,7 +278,8 @@ { stage <- getStage ; case stage of Brack _ RnPendingTyped - -> failWithTc illegalUntypedSplice + -> failWithTc $ thSyntaxError + $ MismatchedSpliceType Untyped IsSplice Brack pop_stage (RnPendingUntyped ps_var) -> do { (splice', fvs) <- setStage pop_stage $ @@ -326,15 +306,14 @@ -- are not executed until the top-level splice is run. checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM () checkTopSpliceAllowed splice = do - let (herald, ext) = spliceExtension splice - extEnabled <- xoptM ext - unless extEnabled - (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text herald <+> text "are not permitted without" <+> ppr ext) + let (ext, err) = spliceExtension splice + unlessXOptM ext $ failWith err where - spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension) - spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) - spliceExtension (HsUntypedSpliceExpr {}) = ("Top-level splices", LangExt.TemplateHaskell) + spliceExtension :: HsUntypedSplice GhcPs -> (LangExt.Extension, TcRnMessage) + spliceExtension (HsQuasiQuote {}) = + (LangExt.QuasiQuotes, TcRnIllegalQuasiQuotes) + spliceExtension (HsUntypedSpliceExpr {}) = + (LangExt.TemplateHaskell, thSyntaxError $ IllegalTHSplice) ------------------ @@ -456,13 +435,10 @@ -> setStage pop_stage rn_splice Brack _ (RnPendingUntyped _) - -> failWithTc illegalTypedSplice + -> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice - _ -> do { extEnabled <- xoptM LangExt.TemplateHaskell - ; unless extEnabled - (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Top-level splices are not permitted without" - <+> ppr LangExt.TemplateHaskell) + _ -> do { unlessXOptM LangExt.TemplateHaskell + (failWith $ thSyntaxError IllegalTHSplice) ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_splice -- checkNoErrs: don't attempt to run the splice if @@ -474,8 +450,9 @@ ; traceRn "rnTypedSplice: typed expression splice" empty ; lcl_rdr <- getLocalRdrEnv ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr - , isLocalGRE gre] + ; let gbl_names = mkNameSet [ greName gre + | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) fvs2 = lcl_names `plusFV` gbl_names @@ -512,6 +489,9 @@ ; return (gHsPar e, fvs) } +thSyntaxError :: THSyntaxError -> TcRnMessage +thSyntaxError err = TcRnTHError $ THSyntaxError err + {- Note [Running splices in the Renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -895,14 +875,6 @@ = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -illegalTypedSplice :: TcRnMessage -illegalTypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Typed splices may not appear in untyped brackets" - -illegalUntypedSplice :: TcRnMessage -illegalUntypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Untyped splices may not appear in typed brackets" - checkThLocalName :: Name -> RnM () checkThLocalName name | isUnboundName name -- Do not report two errors for @@ -915,7 +887,7 @@ Nothing -> return () ; -- Not a locally-bound thing Just (top_lvl, bind_lvl, use_stage) -> do { let use_lvl = thLevel use_stage - ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl + ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -9,29 +9,37 @@ module GHC.Rename.Unbound ( mkUnboundName , mkUnboundNameRdr + , mkUnboundGRE + , mkUnboundGRERdr , isUnboundName , reportUnboundName , reportUnboundName' , unknownNameSuggestions + , similarNameSuggestions + , fieldSelectorSuggestions , WhatLooking(..) , WhereLooking(..) , LookingFor(..) , unboundName , unboundNameX + , unboundTermNameInTypes + , IsTermInTypes(..) , notInScopeErr , nameSpacesRelated + , termNameInType ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) import GHC.Utils.Misc +import GHC.Utils.Panic (panic) import GHC.Data.Maybe import GHC.Data.FastString @@ -93,9 +101,17 @@ , lf_where :: WhereLooking } +data IsTermInTypes = UnknownTermInTypes RdrName | TermInTypes RdrName | NoTermInTypes + mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) +mkUnboundGRE :: OccName -> GlobalRdrElt +mkUnboundGRE occ = mkLocalGRE UnboundGRE NoParent $ mkUnboundName occ + +mkUnboundGRERdr :: RdrName -> GlobalRdrElt +mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr + reportUnboundName' :: WhatLooking -> RdrName -> RnM Name reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr @@ -107,11 +123,24 @@ unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name unboundNameX looking_for rdr_name hints + = unboundNameOrTermInType NoTermInTypes looking_for rdr_name hints + +unboundTermNameInTypes :: LookingFor -> RdrName -> RdrName -> RnM Name +unboundTermNameInTypes looking_for rdr_name demoted_rdr_name + = unboundNameOrTermInType (UnknownTermInTypes demoted_rdr_name) looking_for rdr_name [] + +-- Catches imported qualified terms in type signatures +-- with proper error message and suggestions +termNameInType :: LookingFor -> RdrName -> RdrName -> [GhcHint] -> RnM Name +termNameInType looking_for rdr_name demoted_rdr_name external_hints + = unboundNameOrTermInType (TermInTypes demoted_rdr_name) looking_for rdr_name external_hints + +unboundNameOrTermInType :: IsTermInTypes -> LookingFor -> RdrName -> [GhcHint] -> RnM Name +unboundNameOrTermInType if_term_in_type looking_for rdr_name hints = do { dflags <- getDynFlags ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - err = notInScopeErr (lf_where looking_for) rdr_name ; if not show_helpful_errors - then addErr $ TcRnNotInScope err rdr_name [] hints + then addErr $ make_error [] hints else do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv ; impInfo <- getImports @@ -122,10 +151,20 @@ dflags hpt currmod global_env local_env impInfo rdr_name ; addErr $ - TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) } + make_error imp_errs (hints ++ suggs) } ; return (mkUnboundNameRdr rdr_name) } + where + name_to_search = case if_term_in_type of + NoTermInTypes -> rdr_name + UnknownTermInTypes demoted_name -> demoted_name + TermInTypes demoted_name -> demoted_name + err = notInScopeErr (lf_where looking_for) name_to_search + make_error imp_errs hints = case if_term_in_type of + TermInTypes demoted_name -> TcRnTermNameInType demoted_name hints + _ -> TcRnNotInScope err name_to_search imp_errs hints + notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError notInScopeErr where_look rdr_name | Just name <- isExact_maybe rdr_name @@ -136,11 +175,17 @@ = NotInScope -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable -unknownNameSuggestions :: WhatLooking -> DynFlags - -> HomePackageTable -> Module - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> ([ImportError], [GhcHint]) -unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) +unknownNameSuggestions :: LocalRdrEnv -> WhatLooking -> RdrName -> RnM ([ImportError], [GhcHint]) +unknownNameSuggestions lcl_env what_look tried_rdr_name = + do { dflags <- getDynFlags + ; hpt <- getHpt + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; return $ + unknownNameSuggestions_ + (LF what_look WL_Anywhere) + dflags hpt curr_mod rdr_env lcl_env imp_info tried_rdr_name } unknownNameSuggestions_ :: LookingFor -> DynFlags -> HomePackageTable -> Module @@ -152,7 +197,7 @@ suggs = mconcat [ if_ne (SuggestSimilarNames tried_rdr_name) $ similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name - , map ImportSuggestion imp_suggs + , map (ImportSuggestion $ rdrNameOcc tried_rdr_name) imp_suggs , extensionSuggestions tried_rdr_name , fieldSelectorSuggestions global_env tried_rdr_name ] (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name @@ -168,9 +213,9 @@ | null gres = [] | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents] where - gres = filter isNoFieldSelectorGRE $ - lookupGRE_RdrName' tried_rdr_name global_env - parents = [ parent | ParentIs parent <- map gre_par gres ] + gres = filter isNoFieldSelectorGRE + $ lookupGRE global_env (LookupRdrName tried_rdr_name AllRelevantGREs) + parents = [ parent | ParentIs parent <- map greParent gres ] similarNameSuggestions :: LookingFor -> DynFlags -> GlobalRdrEnv -> LocalRdrEnv @@ -182,7 +227,7 @@ all_possibilities :: [(String, SimilarName)] all_possibilities = case what_look of WL_None -> [] - _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc)) + _ -> [ (showPpr dflags r, SimilarRdrName r (Just $ LocallyBoundAt loc)) | (r,loc) <- local_possibilities local_env ] ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] @@ -213,7 +258,7 @@ global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)] global_possibilities global_env - | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how) + | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just how)) | gre <- globalRdrEnvElts global_env , isGreOk looking_for gre , let occ = greOccName gre @@ -228,7 +273,7 @@ rdr_unqual = mkRdrUnqual occ , correct_name_space occ , sim <- case (unquals_in_scope gre, quals_only gre) of - (how:_, _) -> [ SimilarRdrName rdr_unqual how ] + (how:_, _) -> [ SimilarRdrName rdr_unqual (Just how) ] ([], pr:_) -> [ pr ] -- See Note [Only-quals] ([], []) -> [] ] @@ -256,7 +301,7 @@ quals_only :: GlobalRdrElt -> [SimilarName] -- Ones for which *only* the qualified version is in scope quals_only (gre@GRE { gre_imp = is }) - = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec)) + = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just $ ImportedBy ispec)) | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] @@ -278,9 +323,9 @@ , (mod : mods) <- map fst interesting_imports = ([ModulesDoNotExport (mod :| mods) occ_name], []) | mod : mods <- helpful_imports_non_hiding - = ([], [CouldImportFrom (mod :| mods) occ_name]) + = ([], [CouldImportFrom (mod :| mods)]) | mod : mods <- helpful_imports_hiding - = ([], [CouldUnhideFrom (mod :| mods) occ_name]) + = ([], [CouldUnhideFrom (mod :| mods)]) | otherwise = ([], []) where @@ -288,7 +333,7 @@ (mod_name, occ_name) = case rdr_name of Unqual occ_name -> (Nothing, occ_name) Qual mod_name occ_name -> (Just mod_name, occ_name) - _ -> error "importSuggestions: dead code" + _ -> panic "importSuggestions: dead code" -- What import statements provide "Mod" at all @@ -312,7 +357,8 @@ helpful_imports = filter helpful interesting_imports where helpful (_,imv) = any (isGreOk looking_for) $ - lookupGlobalRdrEnv (imv_all_exports imv) occ_name + lookupGRE (imv_all_exports imv) + (LookupOccName occ_name $ RelevantGREsFOS WantNormal) -- Which of these do that because of an explicit hiding list resp. an -- explicit import list @@ -330,9 +376,9 @@ hpt_uniques = map fst (udfmToList hpt) is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam) glob_mods = nub [ mod - | gre <- globalRdrEnvElts global_env - , (mod, _) <- qualsInScope gre - ] + | gre <- globalRdrEnvElts global_env + , (mod, _) <- qualsInScope gre + ] extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName @@ -374,12 +420,15 @@ -> NameSpace -- ^ Name space of a name that might have been meant -> Bool nameSpacesRelated dflags what_looking ns ns' - = ns' `elem` ns : [ other_ns - | (orig_ns, others) <- other_namespaces - , ns == orig_ns - , (other_ns, wls) <- others - , what_looking `elem` WL_Anything : wls - ] + | ns == ns' + = True + | otherwise + = or [ other_ns ns' + | (orig_ns, others) <- other_namespaces + , orig_ns ns + , (other_ns, wls) <- others + , what_looking `elem` WL_Anything : wls + ] where -- explanation: -- [(orig_ns, [(other_ns, what_looking_possibilities)])] @@ -387,19 +436,21 @@ -- and what_looking is either WL_Anything or is one of -- what_looking_possibilities other_namespaces = - [ (varName , [(dataName, [WL_Constructor])]) - , (dataName , [(varName , [WL_RecField])]) - , (tvName , (tcClsName, [WL_Constructor]) : promoted_datacons) - , (tcClsName, (tvName , []) : promoted_datacons) + [ (isVarNameSpace , [(isFieldNameSpace , [WL_RecField]) + ,(isDataConNameSpace, [WL_Constructor])]) + , (isDataConNameSpace , [(isVarNameSpace , [WL_RecField])]) + , (isTvNameSpace , (isTcClsNameSpace , [WL_Constructor]) + : promoted_datacons) + , (isTcClsNameSpace , (isTvNameSpace , []) + : promoted_datacons) ] -- If -XDataKinds is enabled, the data constructor name space is also -- related to the type-level name spaces data_kinds = xopt LangExt.DataKinds dflags - promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds] + promoted_datacons = [(isDataConNameSpace, [WL_Constructor]) | data_kinds] -{- -Note [Related name spaces] -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Related name spaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Name spaces are related if there is a chance to mean the one when one writes the other, i.e. variables <-> data constructors and type variables <-> type constructors. diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -9,7 +9,7 @@ -} module GHC.Rename.Utils ( - checkDupRdrNames, checkDupRdrNamesN, checkShadowedRdrNames, + checkDupRdrNames, checkShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, dupNamesErr, checkTupSize, checkCTupSize, addFvRn, mapFvRn, mapMaybeFvRn, @@ -17,21 +17,23 @@ warnUnusedTopBinds, warnUnusedLocalBinds, warnForallIdentifier, checkUnusedRecordWildcard, - mkFieldEnv, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, - genHsIntegralLit, genHsTyLit, genSimpleConPat, + wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp, + genAppType, + genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, genSimpleFunBind, genFunBind, newLocalBndrRn, newLocalBndrsRn, - bindLocalNames, bindLocalNamesFV, + bindLocalNames, bindLocalNamesFV, delLocalNames, - addNameClashErrRn, + addNameClashErrRn, mkNameClashErr, checkInferredVars, - noNestedForallsContextsErr, addNoNestedForallsContextsErr + noNestedForallsContextsErr, addNoNestedForallsContextsErr, + + isIrrefutableHsPatRn ) where @@ -43,9 +45,8 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env +-- import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad -import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -54,21 +55,20 @@ import GHC.Types.SourceFile import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) ) -import GHC.Data.List.SetOps ( removeDups ) +import GHC.Types.Basic +import GHC.Data.List.SetOps ( removeDupsOn ) import GHC.Data.Maybe ( whenIsJust ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.FastString import Control.Monad -import Data.List (find, sortBy) import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) -import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt -import GHC.Data.Bag + import qualified Data.List as List +import qualified Data.List.NonEmpty as NE + {- ********************************************************* * * @@ -95,7 +95,7 @@ bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names - = updLclEnv $ \ lcl_env -> + = updLclCtxt $ \ lcl_env -> let th_level = thLevel (tcl_th_ctxt lcl_env) th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) [ (n, (NotTopLevel, th_level)) | n <- names ] @@ -108,20 +108,21 @@ = do { (result, fvs) <- bindLocalNames names enclosed_scope ; return (result, delFVs names fvs) } +delLocalNames :: [Name] -> RnM a -> RnM a +delLocalNames names + = updLclCtxt $ \ lcl_env -> + let th_bndrs' = delListFromNameEnv (tcl_th_bndrs lcl_env) names + rdr_env' = minusLocalRdrEnvList (tcl_rdr lcl_env) (map occName names) + in lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' } + ------------------------------------- checkDupRdrNames :: [LocatedN RdrName] -> RnM () -- Check for duplicated names in a binding group checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLocA) dups - where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc - -checkDupRdrNamesN :: [LocatedN RdrName] -> RnM () --- Check for duplicated names in a binding group -checkDupRdrNamesN rdr_names_w_loc - = mapM_ (dupNamesErr getLocA) dups + = mapM_ (\ ns -> dupNamesErr (getLocA <$> ns) (unLoc <$> ns)) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDupsOn unLoc rdr_names_w_loc checkDupNames :: [Name] -> RnM () -- Check for duplicated names in a binding group @@ -130,9 +131,9 @@ check_dup_names :: [Name] -> RnM () check_dup_names names - = mapM_ (dupNamesErr nameSrcSpan) dups + = mapM_ (\ ns -> dupNamesErr (nameSrcSpan <$> ns) (getRdrName <$> ns)) dups where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + (_, dups) = removeDupsOn nameOccName names --------------------- checkShadowedRdrNames :: [LocatedN RdrName] -> RnM () @@ -171,7 +172,7 @@ where (loc,occ) = get_loc_occ n mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + gres = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantBoth)) -- Make an Unqualified RdrName and look that up, so that -- we don't find any GREs that are in scope qualified-only @@ -193,19 +194,15 @@ -- @{a}@, but @forall a. [a] -> [a]@ would be accepted. -- See @Note [Unobservably inferred type variables]@. checkInferredVars :: HsDocContext - -> Maybe SDoc - -- ^ The error msg if the signature is not allowed to contain - -- manually written inferred variables. -> LHsSigType GhcPs -> RnM () -checkInferredVars _ Nothing _ = return () -checkInferredVars ctxt (Just msg) ty = +checkInferredVars ctxt ty = let bndrs = sig_ty_bndrs ty - in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of - Nothing -> return () - Just _ -> addErr $ + in case filter ((==) InferredSpec . hsTyVarBndrFlag) bndrs of + [] -> return () + iv : ivs -> addErr $ TcRnWithHsDocContext ctxt $ - mkTcRnUnknownMessage $ mkPlainError noHints msg + TcRnIllegalInferredTyVars (iv NE.:| ivs) where sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs] sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) @@ -288,7 +285,9 @@ -- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind"). -- See @Note [No nested foralls or contexts in instance types]@ in -- "GHC.Hs.Type". -noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage) +noNestedForallsContextsErr :: NestedForallsContextsIn + -> LHsType GhcRn + -> Maybe (SrcSpan, TcRnMessage) noNestedForallsContextsErr what lty = case ignoreParens lty of L l (HsForAllTy { hst_tele = tele }) @@ -305,12 +304,13 @@ _ -> Nothing where nested_foralls_contexts_err = - mkTcRnUnknownMessage $ mkPlainError noHints $ - what <+> text "cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" + TcRnNestedForallsContexts what -- | A common way to invoke 'noNestedForallsContextsErr'. -addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () +addNoNestedForallsContextsErr :: HsDocContext + -> NestedForallsContextsIn + -> LHsType GhcRn + -> RnM () addNoNestedForallsContextsErr ctxt what lty = whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> addErrAt l $ TcRnWithHsDocContext ctxt err_msg @@ -356,8 +356,8 @@ warnUnusedTopBinds gres = whenWOptM Opt_WarnUnusedTopBinds $ do env <- getGblEnv - let isBoot = tcg_src env == HsBootFile - let noParent gre = case gre_par gre of + let isBoot = isHsBootFile $ tcg_src env + let noParent gre = case greParent gre of NoParent -> True _ -> False -- Don't warn about unused bindings with parents in @@ -396,13 +396,7 @@ -- -- The `..` here doesn't bind any variables as `x` is already bound. warnRedundantRecordWildcard :: RnM () -warnRedundantRecordWildcard = - whenWOptM Opt_WarnRedundantRecordWildcards $ - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) - noHints - redundantWildcardWarning - in addDiagnostic msg +warnRedundantRecordWildcard = addDiagnostic TcRnRedundantRecordWildcard -- | Produce a warning when no variables bound by a `..` pattern are used. @@ -419,21 +413,19 @@ warnUnusedRecordWildcard ns used_names = do let used = filter (`elemNameSet` used_names) ns traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) - warnIf (null used) - unusedRecordWildcardWarning + warnIf (null used) (TcRnUnusedRecordWildcard ns) warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns :: [Name] -> FreeVars -> RnM () -warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds -warnUnusedMatches = check_unused Opt_WarnUnusedMatches -warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns +warnUnusedLocalBinds = check_unused UnusedNameLocalBind +warnUnusedMatches = check_unused UnusedNameMatch +warnUnusedTypePatterns = check_unused UnusedNameTypePattern -check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () -check_unused flag bound_names used_names - = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) - bound_names)) +check_unused :: UnusedNameProv -> [Name] -> FreeVars -> RnM () +check_unused prov bound_names used_names + = warnUnused prov (filterOut (`elemNameSet` used_names) bound_names) warnForallIdentifier :: LocatedN RdrName -> RnM () warnForallIdentifier (L l rdr_name@(Unqual occ)) @@ -448,75 +440,42 @@ warnUnusedGREs gres = mapM_ warnUnusedGRE gres -- NB the Names must not be the names of record fields! -warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = - mapM_ (warnUnused1 flag . NormalGreName) names +warnUnused :: UnusedNameProv -> [Name] -> RnM () +warnUnused prov names = + mapM_ (\ nm -> warnUnused1 prov nm (nameOccName nm)) names -warnUnused1 :: WarningFlag -> GreName -> RnM () -warnUnused1 flag child - = when (reportable child) $ - addUnusedWarning flag - (occName child) (greNameSrcSpan child) - (text $ "Defined but not used" ++ opt_str) - where - opt_str = case flag of - Opt_WarnUnusedTypePatterns -> " on the right hand side" - _ -> "" +warnUnused1 :: UnusedNameProv -> Name -> OccName -> RnM () +warnUnused1 prov child child_occ + = when (reportable child child_occ) $ + warn_unused_name prov (nameSrcSpan child) child_occ +warn_unused_name :: UnusedNameProv -> SrcSpan -> OccName -> RnM () +warn_unused_name prov span child_occ = + addDiagnosticAt span (TcRnUnusedName child_occ prov) + warnUnusedGRE :: GlobalRdrElt -> RnM () warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) - | lcl = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre) - | otherwise = when (reportable (gre_name gre)) (mapM_ warn is) + | lcl = warnUnused1 UnusedNameTopDecl nm occ + | otherwise = when (reportable nm occ) (mapM_ warn is) where occ = greOccName gre - warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg - where - span = importSpecLoc spec - pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> text "but not used" - --- | Make a map from selector names to field labels and parent tycon --- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) -mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre)) - | gres <- nonDetOccEnvElts rdr_env - , gre <- gres - , Just fl <- [greFieldLabel gre] - ] + nm = greName gre + warn spec = + warn_unused_name (UnusedNameImported (importSpecModule spec)) span occ + where + span = importSpecLoc spec -- | Should we report the fact that this 'Name' is unused? The -- 'OccName' may differ from 'nameOccName' due to -- DuplicateRecordFields. -reportable :: GreName -> Bool -reportable child - | NormalGreName name <- child - , isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore (occName child)) - -addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg = do - let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] - addDiagnosticAt span diag - -unusedRecordWildcardWarning :: TcRnMessage -unusedRecordWildcardWarning = - mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ - wildcardDoc $ text "No variables bound in the record wildcard match are used" - -redundantWildcardWarning :: SDoc -redundantWildcardWarning = - wildcardDoc $ text "Record wildcard does not bind any new variables" - -wildcardDoc :: SDoc -> SDoc -wildcardDoc herald = - herald - $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" - <+> quotes (text "..")) +reportable :: Name -> OccName -> Bool +reportable child child_occ + | isWiredInName child + = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise + = not (startsWithUnderscore child_occ) {- Note [Skipping ambiguity errors at use sites of local declarations] @@ -555,45 +514,9 @@ -- already, and we don't want an error cascade. = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) - , text "It could refer to" - , nest 3 (vcat (msg1 : msgs)) ]) + = do { gre_env <- getGlobalRdrEnv + ; addErr $ mkNameClashErr gre_env rdr_name gres } where - np1 NE.:| nps = gres - msg1 = text "either" <+> ppr_gre np1 - msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_greMangledName gre <> comma - , pprNameProvenance gre] - - -- When printing the name, take care to qualify it in the same - -- way as the provenance reported by pprNameProvenance, namely - -- the head of 'gre_imp'. Otherwise we get confusing reports like - -- Ambiguous occurrence ‘null’ - -- It could refer to either ‘T15487a.null’, - -- imported from ‘Prelude’ at T15487.hs:1:8-13 - -- or ... - -- See #15487 - pp_greMangledName gre@(GRE { gre_name = child, gre_par = par - , gre_lcl = lcl, gre_imp = iss }) = - case child of - FieldGreName fl -> text "the field" <+> quotes (ppr fl) <+> parent_info - NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name)) - where - parent_info = case par of - NoParent -> empty - ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name) - pp_qual name - | lcl - = ppr (nameModule name) - | Just imp <- headMaybe iss -- This 'imp' is the one that - -- pprNameProvenance chooses - , ImpDeclSpec { is_as = mod } <- is_decl imp - = ppr mod - | otherwise - = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) - -- Invariant: either 'lcl' is True or 'iss' is non-empty - -- If all the GREs are defined locally, can we skip reporting an ambiguity -- error at use sites, because it will have been reported already? See -- Note [Skipping ambiguity errors at use sites of local declarations] @@ -605,34 +528,23 @@ num_flds = length flds num_non_flds = length non_flds +mkNameClashErr :: GlobalRdrEnv -> RdrName -> NE.NonEmpty GlobalRdrElt -> TcRnMessage +mkNameClashErr gre_env rdr_name gres = TcRnAmbiguousName gre_env rdr_name gres -dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () -dupNamesErr get_loc names - = addErrAt big_loc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), - locations] +dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM () +dupNamesErr locs names + = addErrAt big_loc (TcRnBindingNameConflict (NE.head names) locs) where - locs = map get_loc (NE.toList names) - big_loc = foldr1 combineSrcSpans locs - locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs)) + big_loc = foldr1 combineSrcSpans locs badQualBndrErr :: RdrName -> TcRnMessage -badQualBndrErr rdr_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Qualified name in binding position:" <+> ppr rdr_name +badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name -typeAppErr :: String -> LHsType GhcPs -> TcRnMessage -typeAppErr what (L _ k) - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal visible" <+> text what <+> text "application" - <+> quotes (char '@' <> ppr k)) - 2 (text "Perhaps you intended to use TypeApplications") +typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage +typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled (TypeApplication k what) badFieldConErr :: Name -> FieldLabelString -> TcRnMessage -badFieldConErr con field - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] +badFieldConErr con field = TcRnInvalidRecordField con field -- | Ensure that a boxed or unboxed tuple has arity no larger than -- 'mAX_TUPLE_SIZE'. @@ -641,10 +553,7 @@ | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", - nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")] + = addErr (TcRnTupleTooLarge tup_size) -- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'. checkCTupSize :: Int -> TcM () @@ -652,10 +561,7 @@ | tup_size <= mAX_CTUPLE_SIZE = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Constraint tuple arity too large:" <+> int tup_size - <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple") + = addErr (TcRnCTupleTooLarge tup_size) {- ********************************************************************* * * @@ -675,6 +581,9 @@ genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg +genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn +genLHsApp fun arg = wrapGenSpan (genHsApp fun arg) + genLHsVar :: Name -> LHsExpr GhcRn genLHsVar nm = wrapGenSpan $ genHsVar nm @@ -684,8 +593,11 @@ genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty)) +genLHsLit :: HsLit GhcRn -> LocatedAn an (HsExpr GhcRn) +genLHsLit = wrapGenSpan . HsLit noAnn + genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) -genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) +genHsIntegralLit = genLHsLit . HsInt noExtField genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText @@ -716,6 +628,11 @@ -> HsBind GhcRn genFunBind fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup Generated (wrapGenSpan ms) + , fun_matches = mkMatchGroup (Generated SkipPmc) (wrapGenSpan ms) , fun_ext = emptyNameSet } + +isIrrefutableHsPatRn :: forall p. (OutputableBndrId p) + => DynFlags -> LPat (GhcPass p) -> Bool +isIrrefutableHsPatRn dflags = + isIrrefutableHsPat (xopt LangExt.Strict dflags) 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 @@ -50,7 +50,7 @@ import GHC.Driver.Main import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Config @@ -66,12 +66,13 @@ import GHC.Hs -import GHC.Core.Predicate -import GHC.Core.InstEnv +import GHC.Core.Class (classTyCon) import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst ) +import GHC.Core.InstEnv +import GHC.Core.Predicate +import GHC.Core.TyCo.Ppr import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) -import GHC.Core.TyCo.Ppr import qualified GHC.Core.Type as Type import GHC.Iface.Env ( newInteractiveBinder ) @@ -85,12 +86,13 @@ import GHC.Data.FastString import GHC.Data.Bag -import GHC.Utils.Monad -import GHC.Utils.Panic import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Misc +import GHC.Utils.Exception import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -114,29 +116,28 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Home.ModInfo -import System.Directory +import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) +import GHC.Tc.Solver (simplifyWantedsTcM) +import GHC.Tc.Utils.Env (tcGetInstEnvs, lookupGlobal) +import GHC.Tc.Utils.Instantiate (instDFunType) +import GHC.Tc.Utils.Monad +import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) ) + +import GHC.Unit.Env +import GHC.IfaceToCore + +import Control.Monad +import Control.Monad.Catch as MC +import Data.Array import Data.Dynamic import Data.Either import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate) import Data.List.NonEmpty (NonEmpty) -import Control.Monad -import Control.Monad.Catch as MC -import Data.Array -import GHC.Utils.Exception +import System.Directory 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 (simplifyWantedsTcM) -import GHC.Tc.Utils.Monad -import GHC.Core.Class (classTyCon) -import GHC.Unit.Env -import GHC.IfaceToCore - -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -324,14 +325,15 @@ | otherwise = not_tracing where tracing - | EvalBreak is_exception apStack_ref ix mod_name resume_ctxt _ccs <- status + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status , not is_exception = do hsc_env <- getSession let interp = hscInterp hsc_env let dflags = hsc_dflags hsc_env let hmi = expectJust "handleRunStatus" $ - lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) modl = mi_module (hm_iface hmi) breaks = getModBreaks hmi @@ -356,14 +358,15 @@ not_tracing -- Hit a breakpoint - | EvalBreak is_exception apStack_ref ix mod_name resume_ctxt ccs <- status + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status = do hsc_env <- getSession let interp = hscInterp hsc_env resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref let hmi = expectJust "handleRunStatus" $ - lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) modl = mi_module (hm_iface hmi) bp | is_exception = Nothing | otherwise = Just (BreakInfo modl ix) @@ -817,8 +820,14 @@ = do { idecls_env <- hscRnImportDecls hsc_env idecls -- This call also loads any orphan modules ; return $ case partitionEithers (map mkEnv imods) of - ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) - (err : _, _) -> Left err } + (err : _, _) -> Left err + ([], imods_env0) -> + -- Need to rehydrate the 'GlobalRdrEnv' to recover the 'GREInfo's. + -- This is done in order to avoid space leaks. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + let imods_env = map (hydrateGlobalRdrEnv get_GRE_info) imods_env0 + in Right (foldr plusGlobalRdrEnv idecls_env imods_env) + } where idecls :: [LImportDecl GhcPs] idecls = [noLocA d | IIDecl d <- imports] @@ -830,7 +839,9 @@ Left err -> Left (mod, err) Right env -> Right env -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv + get_GRE_info nm = tyThingGREInfo <$> lookupGlobal hsc_env nm + +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String IfGlobalRdrEnv mkTopLevEnv hpt modl = case lookupHpt hpt modl of Nothing -> Left "not a home module" @@ -838,6 +849,9 @@ case mi_globals (hm_iface details) of Nothing -> Left "not interpreted" Just env -> Right env + -- It's OK to be lazy here; we force the GlobalRdrEnv before storing it + -- in ModInfo; see GHCi.UI.Info. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -893,7 +907,7 @@ -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env -> - return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)))) + return $ map greName $ globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)) -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated. 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 @@ -41,9 +41,10 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) ) +import GHC.Tc.Zonk.Type import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env +import GHC.Tc.Zonk.TcType import GHC.Types.Var import GHC.Types.Name @@ -55,7 +56,7 @@ import GHC.Types.Basic ( Boxity(..) ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr import GHC.Utils.Panic @@ -478,22 +479,6 @@ | t == int64PrimTyCon = text $ show (build x :: Int64) | t == word64PrimTyCon = text $ show (build x :: Word64) | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) - | t == stablePtrPrimTyCon = text "" - | t == stableNamePrimTyCon = text "" - | t == statePrimTyCon = text "" - | t == proxyPrimTyCon = text "" - | t == realWorldTyCon = text "" - | t == threadIdPrimTyCon = text "" - | t == weakPrimTyCon = text "" - | t == arrayPrimTyCon = text "" - | t == smallArrayPrimTyCon = text "" - | t == byteArrayPrimTyCon = text "" - | t == mutableArrayPrimTyCon = text "" - | t == smallMutableArrayPrimTyCon = text "" - | t == mutableByteArrayPrimTyCon = text "" - | t == mutVarPrimTyCon = text "" - | t == mVarPrimTyCon = text "" - | t == tVarPrimTyCon = text "" | otherwise = char '<' <> ppr t <> char '>' where build ww = unsafePerformIO $ withArray ww (peek . castPtr) -- This ^^^ relies on the representation of Haskell heap values being @@ -672,7 +657,7 @@ -- Apply the *reverse* substitution in-place to any un-filled-in -- meta tyvars. This recovers the original debugger-world variable -- unless it has been refined by new information from the heap -applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) +applyRevSubst pairs = liftTcM (liftZonkM $ mapM_ do_pair pairs) where do_pair (tc_tv, rtti_tv) = do { tc_ty <- zonkTcTyVar tc_tv @@ -735,7 +720,7 @@ when (check1 old_tvs) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty old_ty hval - new_ty <- zonkTcType (termType term) + new_ty <- liftTcM $ liftZonkM $ zonkTcType (termType term) if isMonomorphic new_ty || check2 new_ty old_ty then do traceTR (text "check2 passed") @@ -905,12 +890,12 @@ return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise = case typePrimRepArgs ty of - [rep_ty] -> do + rep_ty :| [] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + rep_ty :| rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) @@ -1012,11 +997,11 @@ my_ty <- newOpenVar when (check1 old_tvs) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') - search (isMonomorphic `fmap` zonkTcType my_ty) + search (isMonomorphic `fmap` liftZonkM (zonkTcType my_ty)) (\(ty,a) -> go ty a) (Seq.singleton (my_ty, hval)) max_depth - new_ty <- zonkTcType my_ty + new_ty <- liftZonkM $ zonkTcType my_ty if isMonomorphic new_ty || check2 new_ty old_ty then do traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) @@ -1397,8 +1382,8 @@ zonkRttiType :: TcType -> TcM Type -- Zonk the type, replacing any unbound Meta tyvars -- by RuntimeUnk skolems, safely out of Meta-tyvar-land -zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi - ; zonkTcTypeToTypeX ze ty } +zonkRttiType ty + = initZonkEnv RuntimeUnkFlexi $ zonkTcTypeToTypeX ty -------------------------------------------------------------------------------- -- Restore Class predicates out of a representation type diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -0,0 +1,706 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | Interacting with the iserv interpreter, whether it is running on an +-- external process or in the current process. +-- +module GHC.Runtime.Interpreter + ( module GHC.Runtime.Interpreter.Types + + -- * High-level interface to the interpreter + , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) + , resumeStmt + , abandonStmt + , evalIO + , evalString + , evalStringToIOString + , mallocData + , createBCOs + , addSptEntry + , mkCostCentres + , costCentreStackInfo + , newBreakArray + , storeBreakpoint + , breakpointStatus + , getBreakpointVar + , getClosure + , getModBreaks + , seqHValue + , interpreterDynamic + , interpreterProfiled + + -- * The object-code linker + , initObjLinker + , lookupSymbol + , lookupClosure + , loadDLL + , loadArchive + , loadObj + , unloadObj + , addLibrarySearchPath + , removeLibrarySearchPath + , resolveObjs + , findSystemLibrary + + , interpCmd + , withExtInterp + , withExtInterpStatus + , withIServ + , withJSInterp + , stopInterp + , purgeLookupSymbolCache + , freeReallyRemoteRef + , freeHValueRefs + , mkFinalizedHValue + , wormhole, wormholeRef + , fromEvalResult + + -- * Reexport for convenience + , Message (..) + , module GHC.Runtime.Interpreter.Process + ) where + +import GHC.Prelude + +import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Interpreter.JS +import GHC.Runtime.Interpreter.Process +import GHC.Runtime.Utils +import GHCi.Message +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray (BreakArray) +import GHC.Types.BreakInfo (BreakInfo(..)) +import GHC.ByteCode.Types + +import GHC.Linker.Types + +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Types.Unique +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.Basic + +import GHC.Utils.Panic +import GHC.Utils.Exception as Ex +import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) +import GHC.Utils.Fingerprint +import GHC.Utils.Misc + +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.ModInfo +import GHC.Unit.Env + +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHCi.Run +import GHC.Platform.Ways +#endif + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch as MC (mask) +import Data.Binary +import Data.Binary.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Array ((!)) +import Data.IORef +import Foreign hiding (void) +import qualified GHC.Exts.Heap as Heap +import GHC.Stack.CCS (CostCentre,CostCentreStack) +import System.Directory +import System.Process +import GHC.Conc (pseq, par) + +{- Note [Remote GHCi] + ~~~~~~~~~~~~~~~~~~ +When the flag -fexternal-interpreter is given to GHC, interpreted code +is run in a separate process called iserv, and we communicate with the +external process over a pipe using Binary-encoded messages. + +Motivation +~~~~~~~~~~ + +When the interpreted code is running in a separate process, it can +use a different "way", e.g. profiled or dynamic. This means + +- compiling Template Haskell code with -prof does not require + building the code without -prof first + +- when GHC itself is profiled, it can interpret unprofiled code, + and the same applies to dynamic linking. + +- An unprofiled GHCi can load and run profiled code, which means it + can use the stack-trace functionality provided by profiling without + taking the performance hit on the compiler that profiling would + entail. + +For other reasons see remote-GHCi on the wiki. + +Implementation Overview +~~~~~~~~~~~~~~~~~~~~~~~ + +The main pieces are: + +- libraries/ghci, containing: + - types for talking about remote values (GHCi.RemoteTypes) + - the message protocol (GHCi.Message), + - implementation of the messages (GHCi.Run) + - implementation of Template Haskell (GHCi.TH) + - a few other things needed to run interpreted code + +- top-level iserv directory, containing the codefor the external + server. This is a fairly simple wrapper, most of the functionality + is provided by modules in libraries/ghci. + +- This module which provides the interface to the server used + by the rest of GHC. + +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, +interpreted code is run in the same process as GHC. + +Things that do not work with -fexternal-interpreter +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +dynCompileExpr cannot work, because we have no way to run code of an +unknown type in the remote process. This API fails with an error +message if it is used with -fexternal-interpreter. + +Other Notes on Remote GHCi +~~~~~~~~~~~~~~~~~~~~~~~~~~ + * This wiki page has an implementation overview: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter + * Note [External GHCi pointers] in "GHC.Runtime.Interpreter" + * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs +-} + + +-- | Run a command in the interpreter's context. With +-- @-fexternal-interpreter@, the command is serialized and sent to an +-- external iserv process, and the response is deserialized (hence the +-- @Binary@ constraint). With @-fno-external-interpreter@ we execute +-- the command directly here. +interpCmd :: Binary a => Interp -> Message a -> IO a +interpCmd interp msg = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> run msg -- Just run it directly +#endif + ExternalInterp ext -> withExtInterp ext $ \inst -> + uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd] + sendMessage inst msg + + +withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a +withExtInterp ext action = case ext of + ExtJS i -> withJSInterp i action + ExtIServ i -> withIServ i action + +withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a +withExtInterpStatus ext action = case ext of + ExtJS i -> action (interpStatus i) + ExtIServ i -> action (interpStatus i) + +-- Note [uninterruptibleMask_ and interpCmd] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we receive an async exception, such as ^C, while communicating +-- with the iserv process then we will be out-of-sync and not be able +-- to recover. Thus we use uninterruptibleMask_ during +-- communication. A ^C will be delivered to the iserv process (because +-- signals get sent to the whole process group) which will interrupt +-- the running computation and return an EvalException result. + +-- | Grab a lock on the 'IServ' and do something with it. +-- Overloaded because this is used from TcM as well as IO. +withIServ + :: (ExceptionMonad m) + => IServ -> (ExtInterpInstance () -> m a) -> m a +withIServ (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnIServ mstate + action inst + +-- | Spawn JS interpreter if it isn't already running and execute the given action +-- +-- Update the interpreter state. +withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a +withJSInterp (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnJSInterp mstate + action inst + +-- | Spawn an interpreter if not already running according to the status in the +-- MVar. Update the status, free pending heap references, and return the +-- interpreter instance. +-- +-- This function is generic to support both the native external interpreter and +-- the JS one. +spawnInterpMaybe :: ExceptionMonad m => cfg -> (cfg -> IO (ExtInterpInstance d)) -> ExtInterpStatusVar d -> m (ExtInterpInstance d) +spawnInterpMaybe cfg spawn mstatus = do + inst <- liftIO $ modifyMVarMasked mstatus $ \case + -- start the external iserv process if we haven't done so yet + InterpPending -> do + inst <- spawn cfg + pure (InterpRunning inst, inst) + + InterpRunning inst -> do + pure (InterpRunning inst, inst) + + -- free any ForeignRef that have been garbage collected. + pending_frees <- liftIO $ swapMVar (instPendingFrees inst) [] + liftIO $ when (not (null (pending_frees))) $ + sendMessage inst (FreeHValueRefs pending_frees) + + -- run the inner action + pure inst + +withExtInterpMaybe + :: (ExceptionMonad m) + => ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a +withExtInterpMaybe ext action = withExtInterpStatus ext $ \mstate -> do + liftIO (readMVar mstate) >>= \case + InterpPending {} -> action Nothing -- already shut down or never launched + InterpRunning inst -> action (Just inst) + +-- ----------------------------------------------------------------------------- +-- Wrappers around messages + +-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for +-- each of the results. +evalStmt + :: Interp + -> EvalOpts + -> EvalExpr ForeignHValue + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +evalStmt interp opts foreign_expr = do + status <- withExpr foreign_expr $ \expr -> + interpCmd interp (EvalStmt opts expr) + handleEvalStatus interp status + where + withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a + withExpr (EvalThis fhv) cont = + withForeignRef fhv $ \hvref -> cont (EvalThis hvref) + withExpr (EvalApp fl fr) cont = + withExpr fl $ \fl' -> + withExpr fr $ \fr' -> + cont (EvalApp fl' fr') + +resumeStmt + :: Interp + -> EvalOpts + -> ForeignRef (ResumeContext [HValueRef]) + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +resumeStmt interp opts resume_ctxt = do + status <- withForeignRef resume_ctxt $ \rhv -> + interpCmd interp (ResumeStmt opts rhv) + handleEvalStatus interp status + +abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO () +abandonStmt interp resume_ctxt = + withForeignRef resume_ctxt $ \rhv -> + interpCmd interp (AbandonStmt rhv) + +handleEvalStatus + :: Interp + -> EvalStatus [HValueRef] + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +handleEvalStatus interp status = + case status of + EvalBreak a b c d e f -> return (EvalBreak a b c d e f) + EvalComplete alloc res -> + EvalComplete alloc <$> addFinalizer res + where + addFinalizer (EvalException e) = return (EvalException e) + addFinalizer (EvalSuccess rs) = + EvalSuccess <$> mapM (mkFinalizedHValue interp) rs + +-- | Execute an action of type @IO ()@ +evalIO :: Interp -> ForeignHValue -> IO () +evalIO interp fhv = + liftIO $ withForeignRef fhv $ \fhv -> + interpCmd interp (EvalIO fhv) >>= fromEvalResult + +-- | Execute an action of type @IO String@ +evalString :: Interp -> ForeignHValue -> IO String +evalString interp fhv = + liftIO $ withForeignRef fhv $ \fhv -> + interpCmd interp (EvalString fhv) >>= fromEvalResult + +-- | Execute an action of type @String -> IO String@ +evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String +evalStringToIOString interp fhv str = + liftIO $ withForeignRef fhv $ \fhv -> + interpCmd interp (EvalStringToString fhv str) >>= fromEvalResult + + +-- | Allocate and store the given bytes in memory, returning a pointer +-- to the memory in the remote process. +mallocData :: Interp -> ByteString -> IO (RemotePtr ()) +mallocData interp bs = interpCmd interp (MallocData bs) + +mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres interp mod ccs = + interpCmd interp (MkCostCentres mod ccs) + +-- | Create a set of BCOs that may be mutually recursive. +createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef] +createBCOs interp rbcos = do + -- Serializing ResolvedBCO is expensive, so we do it in parallel + interpCmd interp (CreateBCOs puts) + where + puts = parMap doChunk (chunkList 100 rbcos) + + -- make sure we force the whole lazy ByteString + doChunk c = pseq (LB.length bs) bs + where bs = runPut (put c) + + -- We don't have the parallel package, so roll our own simple parMap + parMap _ [] = [] + parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) + where fx = f x; fxs = parMap f xs + +addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO () +addSptEntry interp fpr ref = + withForeignRef ref $ \val -> + interpCmd interp (AddSptEntry fpr val) + +costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String] +costCentreStackInfo interp ccs = + interpCmd interp (CostCentreStackInfo ccs) + +newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray) +newBreakArray interp size = do + breakArray <- interpCmd interp (NewBreakArray size) + mkFinalizedHValue interp breakArray + +storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO () +storeBreakpoint interp ref ix cnt = do -- #19157 + withForeignRef ref $ \breakarray -> + interpCmd interp (SetupBreakpoint breakarray ix cnt) + +breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool +breakpointStatus interp ref ix = + withForeignRef ref $ \breakarray -> + interpCmd interp (BreakpointStatus breakarray ix) + +getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) +getBreakpointVar interp ref ix = + withForeignRef ref $ \apStack -> do + mb <- interpCmd interp (GetBreakpointVar apStack ix) + mapM (mkFinalizedHValue interp) mb + +getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue) +getClosure interp ref = + withForeignRef ref $ \hval -> do + mb <- interpCmd interp (GetClosure hval) + mapM (mkFinalizedHValue interp) mb + +-- | Send a Seq message to the iserv process to force a value #2950 +seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ()) +seqHValue interp unit_env ref = + withForeignRef ref $ \hval -> do + status <- interpCmd interp (Seq hval) + handleSeqHValueStatus interp unit_env status + +-- | Process the result of a Seq or ResumeSeq message. #2950 +handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) +handleSeqHValueStatus interp unit_env eval_status = + case eval_status of + (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do + -- A breakpoint was hit; inform the user and tell them + -- which breakpoint was hit. + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt + let hmi = expectJust "handleRunStatus" $ + lookupHptDirectly (ue_hpt unit_env) + (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + bp | is_exception = Nothing + | otherwise = Just (BreakInfo modl ix) + sdocBpLoc = brackets . ppr . getSeqBpSpan + putStrLn ("*** Ignoring breakpoint " ++ + (showSDocUnsafe $ sdocBpLoc bp)) + -- resume the seq (:force) processing in the iserv process + withForeignRef resume_ctxt_fhv $ \hval -> do + status <- interpCmd interp (ResumeSeq hval) + handleSeqHValueStatus interp unit_env status + (EvalComplete _ r) -> return r + where + getSeqBpSpan :: Maybe BreakInfo -> SrcSpan + -- Just case: Stopped at a breakpoint, extract SrcSpan information + -- from the breakpoint. + getSeqBpSpan (Just BreakInfo{..}) = + (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number + -- Nothing case - should not occur! + -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq + getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "") + breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $ + lookupHpt (ue_hpt unit_env) (moduleName mod) + + +-- ----------------------------------------------------------------------------- +-- Interface to the object-code linker + +initObjLinker :: Interp -> IO () +initObjLinker interp = interpCmd interp InitLinker + +lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ())) +lookupSymbol interp str = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) +#endif + + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> do + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + cache <- readMVar (instLookupSymbolCache inst) + case lookupUFM cache str of + Just p -> return (Just p) + Nothing -> do + m <- uninterruptibleMask_ $ + sendMessage inst (LookupSymbol (unpackFS str)) + case m of + Nothing -> return Nothing + Just r -> do + let p = fromRemotePtr r + cache' = addToUFM cache str p + modifyMVar_ (instLookupSymbolCache inst) (const (pure cache')) + return (Just p) + + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + +lookupClosure :: Interp -> String -> IO (Maybe HValueRef) +lookupClosure interp str = + interpCmd interp (LookupClosure str) + +purgeLookupSymbolCache :: Interp -> IO () +purgeLookupSymbolCache interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> pure () +#endif + ExternalInterp ext -> withExtInterpMaybe ext $ \case + Nothing -> pure () -- interpreter stopped, nothing to do + Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM)) + +-- | loadDLL loads a dynamic library using the OS's native linker +-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either +-- an absolute pathname to the file, or a relative filename +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL +-- searches the standard locations for the appropriate library. +-- +-- Returns: +-- +-- Nothing => success +-- Just err_msg => failure +loadDLL :: Interp -> String -> IO (Maybe String) +loadDLL interp str = interpCmd interp (LoadDLL str) + +loadArchive :: Interp -> String -> IO () +loadArchive interp path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + interpCmd interp (LoadArchive path') + +loadObj :: Interp -> String -> IO () +loadObj interp path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + interpCmd interp (LoadObj path') + +unloadObj :: Interp -> String -> IO () +unloadObj interp path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + interpCmd interp (UnloadObj path') + +-- Note [loadObj and relative paths] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- the iserv process might have a different current directory from the +-- GHC process, so we must make paths absolute before sending them +-- over. + +addLibrarySearchPath :: Interp -> String -> IO (Ptr ()) +addLibrarySearchPath interp str = + fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str) + +removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool +removeLibrarySearchPath interp p = + interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p)) + +resolveObjs :: Interp -> IO SuccessFlag +resolveObjs interp = successIf <$> interpCmd interp ResolveObjs + +findSystemLibrary :: Interp -> String -> IO (Maybe String) +findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str) + +-- ----------------------------------------------------------------------------- +-- IServ specific calls and messages + +-- | Spawn an external interpreter +spawnIServ :: IServConfig -> IO (ExtInterpInstance ()) +spawnIServ conf = do + iservConfTrace conf + let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp + ; return ph }) + (iservConfHook conf) + (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf) + [] + (iservConfOpts conf) + lo_ref <- newIORef Nothing + let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } + let process = InterpProcess + { interpHandle = ph + , interpPipe = pipe + } + + pending_frees <- newMVar [] + lookup_cache <- newMVar emptyUFM + let inst = ExtInterpInstance + { instProcess = process + , instPendingFrees = pending_frees + , instLookupSymbolCache = lookup_cache + , instExtra = () + } + pure inst + +-- | Stop the interpreter +stopInterp :: Interp -> IO () +stopInterp interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> pure () +#endif + ExternalInterp ext -> withExtInterpStatus ext $ \mstate -> do + MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do + case state of + InterpPending -> pure state -- already stopped + InterpRunning i -> do + ex <- getProcessExitCode (interpHandle (instProcess i)) + if isJust ex + then pure () + else sendMessage i Shutdown + pure InterpPending + +-- ----------------------------------------------------------------------------- +{- Note [External GHCi pointers] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have the following ways to reference things in GHCi: + +HValue +------ + +HValue is a direct reference to a value in the local heap. Obviously +we cannot use this to refer to things in the external process. + + +RemoteRef +--------- + +RemoteRef is a StablePtr to a heap-resident value. When -fexternal-interpreter +or the JS interpreter is used, this value resides in the external process's +heap. RemoteRefs are mostly used to send pointers in messages between GHC and +iserv. + +A RemoteRef must be explicitly freed when no longer required, using +freeHValueRefs, or by attaching a finalizer with mkForeignHValue. + +To get from a RemoteRef to an HValue you can use 'wormholeRef', which +fails with an error message if -fexternal-interpreter is in use. + +ForeignRef +---------- + +A ForeignRef is a RemoteRef with a finalizer that will free the +'RemoteRef' when it is garbage collected. We mostly use ForeignHValue +on the GHC side. + +The finalizer adds the RemoteRef to the iservPendingFrees list in the +IServ record. The next call to interpCmd will free any RemoteRefs in +the list. It was done this way rather than calling interpCmd directly, +because I didn't want to have arbitrary threads calling interpCmd. In +principle it would probably be ok, but it seems less hairy this way. +-} + +-- | Creates a 'ForeignRef' that will automatically release the +-- 'RemoteRef' when it is no longer referenced. +mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a) +mkFinalizedHValue interp rref = do + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> mkForeignRef rref (freeRemoteRef rref) +#endif + ExternalInterp ext -> withExtInterpMaybe ext $ \case + Nothing -> mkForeignRef rref (pure ()) -- nothing to do, interpreter already stopped + Just inst -> mkForeignRef rref (freeReallyRemoteRef inst rref) + +freeReallyRemoteRef :: ExtInterpInstance d -> RemoteRef a -> IO () +freeReallyRemoteRef inst rref = + -- add to the list of HValues to free + modifyMVar_ (instPendingFrees inst) (\xs -> pure (castRemoteRef rref : xs)) + + +freeHValueRefs :: Interp -> [HValueRef] -> IO () +freeHValueRefs _ [] = return () +freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs) + +-- | Convert a 'ForeignRef' to the value it references directly. This +-- only works when the interpreter is running in the same process as +-- the compiler, so it fails when @-fexternal-interpreter@ is on. +wormhole :: Interp -> ForeignRef a -> IO a +wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r) + +-- | Convert an 'RemoteRef' to the value it references directly. This +-- only works when the interpreter is running in the same process as +-- the compiler, so it fails when @-fexternal-interpreter@ is on. +wormholeRef :: Interp -> RemoteRef a -> IO a +wormholeRef interp _r = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> localRef _r +#endif + ExternalInterp {} + -> throwIO (InstallationError "this operation requires -fno-external-interpreter") + +-- ----------------------------------------------------------------------------- +-- Misc utils + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a + +getModBreaks :: HomeModInfo -> ModBreaks +getModBreaks hmi + | Just linkable <- homeModInfoByteCode hmi, + [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable + = fromMaybe emptyModBreaks (bc_breaks cbc) + | otherwise + = emptyModBreaks -- probably object code + where + -- The linkable may have 'DotO's as well; only consider BCOs. See #20570. + onlyBCOs :: Unlinked -> Maybe CompiledByteCode + onlyBCOs (BCOs cbc _) = Just cbc + onlyBCOs _ = Nothing + +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +interpreterProfiled interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsProfiled +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfProfiled (interpConfig i) + ExtJS {} -> False -- we don't support profiling yet in the JS backend + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +interpreterDynamic interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsDynamic +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfDynamic (interpConfig i) + ExtJS {} -> False -- dynamic doesn't make sense for JS diff --git a/compiler/GHC/Runtime/Interpreter/JS.hs b/compiler/GHC/Runtime/Interpreter/JS.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Runtime/Interpreter/JS.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript interpreter +-- +-- See Note [The JS interpreter] +-- +module GHC.Runtime.Interpreter.JS + ( spawnJSInterp + , jsLinkRts + , jsLinkInterp + , jsLinkObject + , jsLinkObjects + , jsLoadFile + , jsRunServer + -- * Reexported for convenience + , mkExportedModFuns + ) +where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Interpreter.Process +import GHC.Runtime.Utils +import GHCi.Message + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Linker +import GHC.StgToJS.Types +import GHC.StgToJS.Object + +import GHC.Unit.Env +import GHC.Unit.Types +import GHC.Unit.State + +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Panic +import GHC.Utils.Error (logInfo) +import GHC.Utils.Outputable (text) +import GHC.Data.FastString +import GHC.Types.Unique.FM + +import Control.Concurrent +import Control.Monad + +import System.Process +import System.IO +import System.FilePath + +import Data.IORef +import qualified Data.Set as Set +import qualified Data.ByteString as B + +import Foreign.C.String + + +-- Note [The JS interpreter] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS interpreter works as follows: +-- +-- ghc-interp.js is a simple JS script used to bootstrap the external +-- interpreter server (iserv) that is written in Haskell. This script waits for +-- commands on stdin: +-- +-- LOAD foo.js +-- +-- load a JS file in the current JS environment +-- +-- RUN_SERVER ghci_unit_id +-- +-- execute h$main(h$ghci_unit_idZCGHCiziServerzidefaultServer), +-- the entry point of the interpreter server +-- +-- On the GHC side, when we need the interpreter we do the following: +-- +-- 1. spawn nodejs with $topdir/ghc-interp.js script +-- 2. link the JS rts and send a LOAD command to load it +-- 3. link iserv (i.e. use GHCi.Server.defaultServer as root) and LOAD it +-- 4. send a RUN_SERVER command to execute the JS iserv +-- +-- From this moment on, everything happens as with the native iserv, using a +-- pipe for communication, with the following differences: +-- +-- - the JS iserv only supports the LoadObj linking command which has been +-- repurposed to load a JS source file. The JS iserv doesn't deal with +-- libraries (.a) and with object files (.o). The linker state is maintained on +-- the GHC side and GHC only sends the appropriate chunks of JS code to link. +-- +-- - the JS iserv doesn't support ByteCode (i.e. it doesn't support CreateBCOs +-- messages). JS iserv clients should use the usual JS compilation pipeline and +-- send JS code instead. See GHC.Driver.Main.hscCompileCoreExpr for an example. +-- +-- GHC keeps track of JS blocks (JS unit of linking corresponding to top-level +-- binding groups) that have already been linked by the JS interpreter. It only +-- links new ones when necessary. +-- +-- Note that the JS interpreter isn't subject to staging issues: we can use it +-- in a Stage1 GHC. +-- + +--------------------------------------------------------- +-- Running node +--------------------------------------------------------- + +-- | Start NodeJS interactively with "ghc-interp.js" script loaded in +startTHRunnerProcess :: FilePath -> NodeJsSettings -> IO (Handle,InterpProcess) +startTHRunnerProcess interp_js settings = do + interp_in <- newIORef undefined + + let createProc cp = do + let cp' = cp + { std_in = CreatePipe + , std_out = Inherit + , std_err = Inherit + } + (mb_in, _mb_out, _mb_err, hdl) <- createProcess cp' + -- we can't directly return stdin for the process given the current + -- implementation of runWithPipes. So we just use an IORef for this... + case mb_in of + Nothing -> panic "startTHRunnerProcess: expected stdin for interpreter" + Just i -> writeIORef interp_in i + return hdl + + (hdl, rh, wh) <- runWithPipes createProc (nodeProgram settings) + [interp_js] + (nodeExtraArgs settings) + std_in <- readIORef interp_in + + lo_ref <- newIORef Nothing + let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } + let proc = InterpProcess + { interpHandle = hdl + , interpPipe = pipe + } + pure (std_in, proc) + +-- | Spawn a JS interpreter +-- +-- Run NodeJS with "ghc-interp.js" loaded in. Then load GHCi.Server and its deps +-- (including the rts) and run GHCi.Server.defaultServer. +spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra) +spawnJSInterp cfg = do + let logger= jsInterpLogger cfg + when (logVerbAtLeast logger 2) $ + logInfo logger (text "Spawning JS interpreter") + + let tmpfs = jsInterpTmpFs cfg + tmp_dir = jsInterpTmpDir cfg + logger = jsInterpLogger cfg + codegen_cfg = jsInterpCodegenCfg cfg + unit_env = jsInterpUnitEnv cfg + finder_opts = jsInterpFinderOpts cfg + finder_cache = jsInterpFinderCache cfg + + (std_in, proc) <- startTHRunnerProcess (jsInterpScript cfg) (jsInterpNodeConfig cfg) + + js_state <- newMVar (JSState + { jsLinkState = emptyLinkPlan + , jsServerStarted = False + }) + + -- get the unit-id of the ghci package. We need this to load the + -- interpreter code. + ghci_unit_id <- case lookupPackageName (ue_units unit_env) (PackageName (fsLit "ghci")) of + Nothing -> cmdLineErrorIO "JS interpreter: couldn't find \"ghci\" package" + Just i -> pure i + + let extra = JSInterpExtra + { instStdIn = std_in + , instJSState = js_state + , instFinderCache = finder_cache + , instFinderOpts = finder_opts + , instGhciUnitId = ghci_unit_id + } + + pending_frees <- newMVar [] + lookup_cache <- newMVar emptyUFM + let inst = ExtInterpInstance + { instProcess = proc + , instPendingFrees = pending_frees + , instLookupSymbolCache = lookup_cache + , instExtra = extra + } + + -- link rts and its deps + jsLinkRts logger tmpfs tmp_dir codegen_cfg unit_env inst + + -- link interpreter and its deps + jsLinkInterp logger tmpfs tmp_dir codegen_cfg unit_env inst + + -- run interpreter main loop + jsRunServer inst + + pure inst + + + +--------------------------------------------------------- +-- Interpreter commands +--------------------------------------------------------- + +-- | Link JS RTS +jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO () +jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = False -- we need the RTS + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , lcForeignRefs = False -- we don't need foreign references + , lcNoJSExecutables = True -- we don't need executables + , lcNoHsMain = True -- nor HsMain + } + + -- link the RTS and its dependencies (things it uses from `base`, etc.) + let link_spec = LinkSpec + { lks_unit_ids = [rtsUnitId, baseUnitId, primUnitId] + , lks_obj_files = mempty + , lks_obj_root_filter = const False + , lks_extra_roots = mempty + , lks_extra_js = mempty + } + + let finder_opts = instFinderOpts (instExtra inst) + finder_cache = instFinderCache (instExtra inst) + + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache + jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan + +-- | Link JS interpreter +jsLinkInterp :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO () +jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do + + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = True -- we don't need the RTS + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , lcForeignRefs = False -- we don't need foreign references + , lcNoJSExecutables = True -- we don't need executables + , lcNoHsMain = True -- nor HsMain + } + + let is_root _ = True -- FIXME: we shouldn't consider every function as a root + + let ghci_unit_id = instGhciUnitId (instExtra inst) + + -- compute unit dependencies of ghc_unit_id + let unit_map = unitInfoMap (ue_units unit_env) + dep_units <- mayThrowUnitErr $ closeUnitDeps unit_map [(ghci_unit_id,Nothing)] + let units = dep_units ++ [ghci_unit_id] + + -- indicate that our root function is GHCi.Server.defaultServer + let root_deps = Set.fromList $ mkExportedFuns ghci_unit_id (fsLit "GHCi.Server") [fsLit "defaultServer"] + + -- link the interpreter and its dependencies + let link_spec = LinkSpec + { lks_unit_ids = units + , lks_obj_files = mempty + , lks_obj_root_filter = is_root + , lks_extra_roots = root_deps + , lks_extra_js = mempty + } + + let finder_cache = instFinderCache (instExtra inst) + finder_opts = instFinderOpts (instExtra inst) + + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache + + jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan + + +-- | Link object files +jsLinkObjects :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> [FilePath] -> (ExportedFun -> Bool) -> IO () +jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root = do + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = True -- we don't need the RTS (already linked) + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , lcForeignRefs = False -- we don't need foreign references + , lcNoJSExecutables = True -- we don't need executables + , lcNoHsMain = True -- nor HsMain + } + + let units = preloadUnits (ue_units unit_env) + ++ [thUnitId] -- don't forget TH which is an implicit dep + + -- compute dependencies + let link_spec = LinkSpec + { lks_unit_ids = units + , lks_obj_files = fmap ObjFile objs + , lks_obj_root_filter = is_root + , lks_extra_roots = mempty + , lks_extra_js = mempty + } + + let finder_opts = instFinderOpts (instExtra inst) + finder_cache = instFinderCache (instExtra inst) + + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache + + -- link + jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan + + + +-- | Link an object file using the given functions as roots +jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO () +jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do + let is_root f = Set.member f (Set.fromList roots) + let objs = [obj] + jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root + + +-- | Link the given link plan +-- +-- Perform incremental linking by removing what is already linked from the plan +jsLinkPlan :: Logger -> TmpFs -> TempDir -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO () +jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do + ---------------------------------------------------------------- + -- Get already linked stuff and compute incremental plan + ---------------------------------------------------------------- + + old_plan <- jsLinkState <$> readMVar (instJSState (instExtra inst)) + + -- compute new plan discarding what's already linked + let (diff_plan, total_plan) = incrementLinkPlan old_plan link_plan + + ---------------------------------------------------------------- + -- Generate JS code for the incremental plan + ---------------------------------------------------------------- + + tmp_out <- newTempSubDir logger tmpfs tmp_dir + void $ jsLink link_cfg cfg logger tmp_out diff_plan + + -- Code has been linked into the following files: + -- - generated rts from tmp_out/rts.js (depends on link options) + -- - raw js files from tmp_out/lib.js + -- - Haskell generated JS from tmp_out/out.js + + -- We need to combine at least rts.js and lib.js for the RTS because they + -- depend on each other. We might as well combine them all, so that's what we + -- do. + let filenames + | lcNoRts link_cfg = ["lib.js", "out.js"] + | otherwise = ["rts.js", "lib.js", "out.js"] + let files = map (tmp_out ) filenames + let all_js = tmp_out "all.js" + let all_files = all_js : files + withBinaryFile all_js WriteMode $ \h -> do + let cpy i = B.readFile i >>= B.hPut h + mapM_ cpy files + + -- add files to clean + addFilesToClean tmpfs TFL_CurrentModule all_files + + ---------------------------------------------------------------- + -- Link JS code + ---------------------------------------------------------------- + + -- linking JS code depends on the phase we're in: + -- - during in the initialization phase, we send a LoadFile message to the + -- JS server; + -- - once the Haskell server is started, we send a LoadObj message to the + -- Haskell server. + server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst)) + if server_started + then sendMessageNoResponse inst $ LoadObj all_js + else jsLoadFile inst all_js + + ---------------------------------------------------------------- + -- update linker state + ---------------------------------------------------------------- + modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsLinkState = total_plan } + + +-- | Send a command to the JS interpreter +jsSendCommand :: ExtInterpInstance JSInterpExtra -> String -> IO () +jsSendCommand inst cmd = send_cmd cmd + where + extra = instExtra inst + handle = instStdIn extra + send_cmd s = do + withCStringLen s \(p,n) -> hPutBuf handle p n + hFlush handle + +-- | Load a JS file in the interpreter +jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO () +jsLoadFile inst path = jsSendCommand inst ("LOAD " ++ path ++ "\n") + +-- | Run JS server +jsRunServer :: ExtInterpInstance JSInterpExtra -> IO () +jsRunServer inst = do + let ghci_unit_id = instGhciUnitId (instExtra inst) + let zghci_unit_id = zString (zEncodeFS (unitIdFS ghci_unit_id)) + + -- Run `GHCi.Server.defaultServer` + jsSendCommand inst ("RUN_SERVER " ++ zghci_unit_id ++ "\n") + + -- indicate that the Haskell server is now started + modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsServerStarted = True } diff --git a/compiler/GHC/Runtime/Interpreter/Process.hs b/compiler/GHC/Runtime/Interpreter/Process.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Runtime/Interpreter/Process.hs @@ -0,0 +1,102 @@ +module GHC.Runtime.Interpreter.Process + ( + -- * Low-level API + callInterpProcess + , readInterpProcess + , writeInterpProcess + + -- * Message API + , Message(..) + , DelayedResponse (..) + , sendMessage + , sendMessageNoResponse + , sendMessageDelayedResponse + , sendAnyValue + , receiveAnyValue + , receiveDelayedResponse + , receiveTHMessage + + ) +where + +import GHC.Prelude + +import GHC.Runtime.Interpreter.Types +import GHCi.Message + +import GHC.IO (catchException) +import GHC.Utils.Panic +import GHC.Utils.Exception as Ex + +import Data.Binary +import System.Exit +import System.Process + +data DelayedResponse a = DelayedResponse + +-- | Send a message to the interpreter process that doesn't expect a response +sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO () +sendMessageNoResponse i m = writeInterpProcess (instProcess i) (putMessage m) + +-- | Send a message to the interpreter that excepts a response +sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a +sendMessage i m = callInterpProcess (instProcess i) m + +-- | Send a message to the interpreter process whose response is expected later +-- +-- This is useful to avoid forgetting to receive the value and to ensure that +-- the type of the response isn't lost. Use receiveDelayedResponse to read it. +sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a) +sendMessageDelayedResponse i m = do + writeInterpProcess (instProcess i) (putMessage m) + pure DelayedResponse + +-- | Send any value +sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO () +sendAnyValue i m = writeInterpProcess (instProcess i) (put m) + +-- | Expect a value to be received +receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a +receiveAnyValue i get = readInterpProcess (instProcess i) get + +-- | Expect a delayed result to be received now +receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a +receiveDelayedResponse i DelayedResponse = readInterpProcess (instProcess i) get + +-- | Expect a value to be received +receiveTHMessage :: ExtInterpInstance d -> IO THMsg +receiveTHMessage i = receiveAnyValue i getTHMessage + + +-- ----------------------------------------------------------------------------- +-- Low-level API + +-- | Send a 'Message' and receive the response from the interpreter process +callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a +callInterpProcess i msg = + remoteCall (interpPipe i) msg + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +-- | Read a value from the interpreter process +readInterpProcess :: InterpProcess -> Get a -> IO a +readInterpProcess i get = + readPipe (interpPipe i) get + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +-- | Send a value to the interpreter process +writeInterpProcess :: InterpProcess -> Put -> IO () +writeInterpProcess i put = + writePipe (interpPipe i) put + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a +handleInterpProcessFailure i e = do + let hdl = interpHandle i + ex <- getProcessExitCode hdl + case ex of + Just (ExitFailure n) -> + throwIO (InstallationError ("External interpreter terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess hdl + _ <- waitForProcess hdl + throw e diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -23,7 +23,7 @@ import GHC.Prelude import GHC.Data.FastString -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -33,34 +33,37 @@ import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types +import GHC.Rename.Names ( gresFromAvails ) + import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface, cannotFindModule ) -import GHC.Rename.Names ( gresFromAvails ) import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Env import GHCi.RemoteTypes ( HValue ) import GHC.Core.Type ( Type, mkTyConTy ) import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.TyCon ( TyCon ) +import GHC.Core.TyCon ( TyCon(tyConName) ) + import GHC.Types.SrcLoc ( noSrcSpan ) -import GHC.Types.Name ( Name, nameModule_maybe ) +import GHC.Types.Name ( Name, nameModule, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.TyThing import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) -import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , greMangledName, mkRdrQual ) +import GHC.Types.Name.Reader +import GHC.Types.Unique.DFM import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Driver.Config.Finder ( initFinderOpts ) -import GHC.Unit.Module ( Module, ModuleName ) +import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) +import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit) ) import GHC.Unit.Module.ModIface import GHC.Unit.Env import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception @@ -69,10 +72,33 @@ import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) import GHC.Linker.Types -import GHC.Types.Unique.DFM import Data.List (unzip4) +import GHC.Iface.Errors.Ppr import GHC.Driver.Monad +{- Note [Timing of plugin initialization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Plugins needs to be initialised as soon as possible in the pipeline. This is because +driver plugins are executed immediately after being loaded, which can modify anything +in the HscEnv, including the logger and DynFlags (for example #21279). For example, +in ghc/Main.hs the logger is used almost immediately after the session has been initialised +and so if a user overwrites the logger expecting all output to go there then unless +the plugins are initialised before that point then unexpected things will happen. + +We initialise plugins in ghc/Main.hs for the main ghc executable. + +When people are using the GHC API, they also need to initialise plugins +at the highest level possible for things to work as expected. We keep +some defensive calls to plugin initialisation in functions like `load'` and `oneshot` +to catch cases where API users have not initialised their own plugins. + +In addition to this, there needs to be an initialisation call for each module +just in case the user has enabled a plugin just for that module using OPTIONS_GHC +pragma. + +-} + -- | Initialise plugins specified by the current DynFlags and update the session. initializeSessionPlugins :: GhcMonad m => m () initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession @@ -176,7 +202,14 @@ Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case thisGhcUnit == (moduleUnit . nameModule . tyConName) plugin_tycon of { + False -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The plugin module", ppr mod_name + , text "was built with a compiler that is incompatible with the one loading it" + ]) ; + True -> + do { eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) ; case eith_plugin of Left actual_type -> throwGhcExceptionIO (CmdLineError $ @@ -187,7 +220,7 @@ , text "did not have the type" , text "GHC.Plugins.Plugin" , text "as required"]) - Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } + Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } } } -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used @@ -303,7 +336,8 @@ -- being compiled. This was introduced by 57d6798. -- -- Need the module as well to record information in the interface file -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName +lookupRdrNameInModuleForPlugins :: HasDebugCallStack + => HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env @@ -323,17 +357,22 @@ case mb_iface of Just iface -> do -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name + let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name , is_qual = False, is_dloc = noSrcSpan } imp_spec = ImpSpec decl_spec ImpAll - env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (greMangledName gre, iface)) + env = mkGlobalRdrEnv + $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) + case lookupGRE env (LookupRdrName rdr_name (RelevantGREsFOS WantNormal)) of + [gre] -> return (Just (greName gre, iface)) [] -> return Nothing _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err + err -> + let opts = initIfaceMessageOpts dflags + err_txt = missingInterfaceErrorDiagnostic opts + $ cannotFindModule hsc_env mod_name err + in throwCmdLineErrorS dflags err_txt where doc = text "contains a name used in an invocation of lookupRdrNameInModule" diff --git a/compiler/GHC/Runtime/Utils.hs b/compiler/GHC/Runtime/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Runtime/Utils.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +module GHC.Runtime.Utils + ( runWithPipes + ) +where + +import GHC.Prelude + +#if defined(mingw32_HOST_OS) +import Foreign.C +import GHC.IO.Handle.FD (fdToHandle) +import GHC.Utils.Exception as Ex +# if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.Event.Windows (associateHandle') +# endif +#else +import System.Posix as Posix +#endif +import System.Process +import System.IO + +runWithPipes :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +#if defined(mingw32_HOST_OS) +foreign import ccall "io.h _close" + c__close :: CInt -> IO CInt + +foreign import ccall unsafe "io.h _get_osfhandle" + _get_osfhandle :: CInt -> IO CInt + +runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesPOSIX createProc prog pre_opts opts = do + (rfd1, wfd1) <- createPipeFd -- we read on rfd1 + (rfd2, wfd2) <- createPipeFd -- we write on wfd2 + wh_client <- _get_osfhandle wfd1 + rh_client <- _get_osfhandle rfd2 + let args = pre_opts ++ (show wh_client : show rh_client : opts) + ph <- createProc (proc prog args) + rh <- mkHandle rfd1 + wh <- mkHandle wfd2 + return (ph, rh, wh) + where mkHandle :: CInt -> IO Handle + mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd) + +# if defined (__IO_MANAGER_WINIO__) +runWithPipesNative :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesNative createProc prog pre_opts opts = do + (rh, wfd1) <- createPipe -- we read on rfd1 + (rfd2, wh) <- createPipe -- we write on wfd2 + wh_client <- handleToHANDLE wfd1 + rh_client <- handleToHANDLE rfd2 + -- Associate the handle with the current manager + -- but don't touch the ones we're passing to the child + -- since it needs to register the handle with its own manager. + associateHandle' =<< handleToHANDLE rh + associateHandle' =<< handleToHANDLE wh + let args = pre_opts ++ (show wh_client : show rh_client : opts) + ph <- createProc (proc prog args) + return (ph, rh, wh) + +runWithPipes = runWithPipesPOSIX runWithPipesNative +# else +runWithPipes = runWithPipesPOSIX +# endif +#else +runWithPipes createProc prog pre_opts opts = do + (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 + (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 + setFdOption rfd1 CloseOnExec True + setFdOption wfd2 CloseOnExec True + let args = pre_opts ++ (show wfd1 : show rfd2 : opts) + ph <- createProc (proc prog args) + closeFd wfd1 + closeFd rfd2 + rh <- fdToHandle rfd1 + wh <- fdToHandle wfd2 + return (ph, rh, wh) +#endif + 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 @@ -16,11 +16,9 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic -import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir -import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map @@ -74,15 +72,10 @@ -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. let getSetting key = either pgmError pure $ - -- Escape the 'top_dir', to make sure we don't accidentally introduce an - -- unescaped space - getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key + getRawFilePathSetting top_dir settingsFile mySettings key getToolSetting :: String -> ExceptT SettingsError m String - -- Escape the 'mtool_dir', to make sure we don't accidentally introduce - -- an unescaped space - getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key + getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key targetPlatformString <- getSetting "target platform string" - myExtraGccViaCFlags <- getSetting "GCC extra via C opts" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command" cc_args_str <- getToolSetting "C compiler flags" @@ -96,12 +89,22 @@ let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] - cpp_args = map Option (unescapeArgs cpp_args_str) - cc_args = unescapeArgs cc_args_str ++ unreg_cc_args - cxx_args = unescapeArgs cxx_args_str + cpp_args = map Option (words cpp_args_str) + cc_args = words cc_args_str ++ unreg_cc_args + cxx_args = words cxx_args_str + + -- The extra flags we need to pass gcc when we invoke it to compile .hc code. + -- + -- -fwrapv is needed for gcc to emit well-behaved code in the presence of + -- integer wrap around (#952). + extraGccViaCFlags = if platformUnregisterised platform + -- configure guarantees cc support these flags + then ["-fwrapv", "-fno-builtin"] + else [] + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldSupportsSingleModule <- getBooleanSetting "ld supports single module" + ldSupportsResponseFiles <- getBooleanSetting "ld supports response files" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" arSupportsDashL <- getBooleanSetting "ar supports -L" @@ -134,12 +137,12 @@ let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog - ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str) + ld_args = map Option (cc_args ++ words cc_link_args_str) ld_r_prog <- getToolSetting "Merge objects command" ld_r_args <- getToolSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) + | otherwise = Just (ld_r_prog, map Option $ words ld_r_args) llvmTarget <- getSetting "LLVM target" @@ -170,7 +173,7 @@ , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule + , toolSettings_ldSupportsResponseFiles = ldSupportsResponseFiles , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW @@ -210,7 +213,7 @@ , toolSettings_opt_lc = [] , toolSettings_opt_i = [] - , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags + , toolSettings_extraGccViaCFlags = extraGccViaCFlags } , sTargetPlatform = platform @@ -260,19 +263,3 @@ , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit } - --- ---------------------------------------------------------------------------- --- Escape Args helpers --- ---------------------------------------------------------------------------- - --- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs --- a/compiler/GHC/Stg/BcPrep.hs +++ b/compiler/GHC/Stg/BcPrep.hs @@ -37,14 +37,14 @@ bcPrepRHS :: StgRhs -> BcPrepM StgRhs -- explicitly match all constructors so we get a warning if we miss any -bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do +bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr) typ) = do {- If we have a breakpoint directly under an StgRhsClosure we don't need to introduce a new binding for it. -} expr' <- bcPrepExpr expr - pure (StgRhsClosure fvs cc upd args (StgTick bp expr')) -bcPrepRHS (StgRhsClosure fvs cc upd args expr) = - StgRhsClosure fvs cc upd args <$> bcPrepExpr expr + pure (StgRhsClosure fvs cc upd args (StgTick bp expr') typ) +bcPrepRHS (StgRhsClosure fvs cc upd args expr typ) = + StgRhsClosure fvs cc upd args <$> bcPrepExpr expr <*> pure typ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr @@ -59,6 +59,7 @@ ReEntrant [] expr' + tick_ty ) letExp = StgLet noExtFieldSilent bnd (StgApp id []) pure letExp @@ -71,6 +72,7 @@ ReEntrant [voidArgId] expr' + tick_ty ) pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId]) bcPrepExpr (StgTick tick rhs) = @@ -110,10 +112,10 @@ bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs) -- If necessary, modify this Id and body to protect not-necessarily-lifted join points. -- See Note [Not-necessarily-lifted join points], step 2. -bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body) +bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body typ) | isNNLJoinPoint x = ( protectNNLJoinPointId x - , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body) + , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body typ) bcPrepSingleBind bnd = bnd bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding @@ -128,7 +130,7 @@ isNNLJoinPoint :: Id -> Bool isNNLJoinPoint x = isJoinId x && mightBeUnliftedType (idType x) --- Update an Id's type to take a Void# argument. +-- Update an Id's type to take a (# #) argument. -- Precondition: the Id is a not-necessarily-lifted join point. -- See Note [Not-necessarily-lifted join points] protectNNLJoinPointId :: Id -> Id @@ -200,7 +202,7 @@ Our plan is to behave is if the code was f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). - let j :: (Void# -> a) + let j :: ((# #) -> a) j = \ _ -> error @r @a "bloop" in case x of A -> j void# diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -319,11 +319,11 @@ where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs -stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body) +stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body typ) = let body' = stgCseExpr (initEnv in_scope) body - in StgRhsClosure ext ccs upd args body' -stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args) - = StgRhsCon ccs dataCon mu ticks args + in StgRhsClosure ext ccs upd args body' typ +stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args typ) + = StgRhsCon ccs dataCon mu ticks args typ ------------------------------ -- The actual AST traversal -- @@ -427,7 +427,7 @@ -- The RHS of a binding. -- If it is a constructor application, either short-cut it or extend the environment stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) -stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args) +stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args typ) | Just other_bndr <- envLookup dataCon args' env , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] = let env' = addSubst bndr other_bndr env @@ -435,15 +435,15 @@ | otherwise = let env' = addDataCon bndr dataCon args' env -- see Note [Case 1: CSEing allocated closures] - pair = (bndr, StgRhsCon ccs dataCon mu ticks args') + pair = (bndr, StgRhsCon ccs dataCon mu ticks args' typ) in (Just pair, env') where args' = substArgs env args -stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) +stgCseRhs env bndr (StgRhsClosure ext ccs upd args body typ) = let (env1, args') = substBndrs env args env2 = forgetCse env1 -- See Note [Free variables of an StgClosure] body' = stgCseExpr env2 body - in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env) + in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body' typ), env) mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -16,7 +16,7 @@ import GHC.Core.DataCon import GHC.Types.IPE import GHC.Unit.Module -import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan ) +import GHC.Types.Name ( getName, getOccName, occNameFS, nameSrcSpan) import GHC.Data.FastString import Control.Monad (when) @@ -29,7 +29,7 @@ import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) -data SpanWithLabel = SpanWithLabel RealSrcSpan String +data SpanWithLabel = SpanWithLabel RealSrcSpan LexicalFastString data StgDebugOpts = StgDebugOpts { stgDebug_infoTableMap :: !Bool @@ -68,26 +68,22 @@ return (StgRec es) collectStgRhs :: Id -> StgRhs -> M StgRhs -collectStgRhs bndr rhs = - case rhs of - StgRhsClosure ext cc us bs e -> do - e' <- with_span $ collectExpr e - recordInfo bndr e' - return $ StgRhsClosure ext cc us bs e' - StgRhsCon cc dc _mn ticks args -> do - n' <- with_span $ numberDataCon dc ticks - return (StgRhsCon cc dc n' ticks args) - where - -- If the binder name has a span, use that initially as the source position - -- in case we don't get anything better - with_span :: M a -> M a - with_span = - let name = idName bndr in - case nameSrcSpan name of - RealSrcSpan pos _ -> - withSpan (pos, occNameString (getOccName name)) - _ -> id +collectStgRhs bndr (StgRhsClosure ext cc us bs e t) = do + let + name = idName bndr + -- If the name has a span, use that initially as the source position in-case + -- we don't get anything better. + with_span = case nameSrcSpan name of + RealSrcSpan pos _ -> withSpan (pos, LexicalFastString $ occNameFS (getOccName name)) + _ -> id + e' <- with_span $ collectExpr e + recordInfo bndr e' + return $ StgRhsClosure ext cc us bs e' t +collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args typ) = do + n' <- numberDataCon dc ticks + return (StgRhsCon cc dc n' ticks args typ) + recordInfo :: Id -> StgExpr -> M () recordInfo bndr new_rhs = do modLoc <- asks rModLocation @@ -96,7 +92,7 @@ -- A span from the ticks surrounding the new_rhs best_span = quickSourcePos thisFile new_rhs -- A back-up span if the bndr had a source position, many do not (think internally generated ids) - bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr))) + bndr_span = (\s -> SpanWithLabel s (LexicalFastString $ occNameFS (getOccName bndr))) <$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr)) recordStgIdPosition bndr best_span bndr_span @@ -214,7 +210,7 @@ 1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from. 3. Stack represented info tables (return frames) to an approximated source location - of the call that pushed a continuation on the stacks. + of the call that pushed a contiunation on the stacks. During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded @@ -257,7 +253,7 @@ In the old times, each usage of a data constructor used the same info table. This made it impossible to distinguish which actual usage of a data constructor was -contributing primarily to the allocation in a program. Using the `-fdistinct-constructor-tables` flag you +contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you can cause code generation to generate a distinct info table for each usage of a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor was responsible for each allocation. diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {- | Non-global free variable analysis on STG terms. This pass annotates @@ -84,26 +85,31 @@ -- with the free variables needed in the closure -- * Each StgCase is correctly annotated (in its extension field) with -- the variables that must be saved across the case -depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding] +depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [(CgStgTopBinding,ImpFVs)] depSortWithAnnotStgPgm this_mod binds = {-# SCC "STG.depSortWithAnnotStgPgm" #-} - lit_binds ++ map from_scc sccs + zip lit_binds (repeat emptyVarSet) ++ map from_scc sccs where lit_binds :: [CgStgTopBinding] pairs :: [(Id, StgRhs)] (lit_binds, pairs) = flattenTopStgBindings binds - nodes :: [Node Name (Id, CgStgRhs)] + nodes :: [Node Name (Id, CgStgRhs, ImpFVs)] nodes = map (annotateTopPair env0) pairs env0 = Env { locals = emptyVarSet, mod = this_mod } -- Do strongly connected component analysis. Why? -- See Note [Why do we need dependency analysis?] - sccs :: [SCC (Id,CgStgRhs)] + sccs :: [SCC (Id,CgStgRhs,ImpFVs)] sccs = stronglyConnCompFromEdgedVerticesUniq nodes - from_scc (CyclicSCC pairs) = StgTopLifted (StgRec pairs) - from_scc (AcyclicSCC (bndr,rhs)) = StgTopLifted (StgNonRec bndr rhs) + from_scc = \case + AcyclicSCC (bndr,rhs,imp_fvs) -> (StgTopLifted (StgNonRec bndr rhs), imp_fvs) + CyclicSCC triples -> (StgTopLifted (StgRec pairs), imp_fvs) + where + (ids,rhss,imp_fvss) = unzip3 triples + pairs = zip ids rhss + imp_fvs = unionVarSets imp_fvss flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)]) @@ -119,13 +125,13 @@ flatten_one (StgNonRec b r) = [(b,r)] flatten_one (StgRec pairs) = pairs -annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs) +annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs, ImpFVs) annotateTopPair env0 (bndr, rhs) = DigraphNode { node_key = idName bndr - , node_payload = (bndr, rhs') + , node_payload = (bndr, rhs', imp_fvs) , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) } where - (rhs', top_fvs, _) = rhsFVs env0 rhs + (rhs', imp_fvs, top_fvs, _) = rhsFVs env0 rhs -------------------------------------------------------------------------------- -- * Non-global free variable analysis @@ -158,6 +164,12 @@ -- analysis on the top-level bindings. type TopFVs = IdSet +-- | ImpFVs: set of variables that are imported +-- +-- It is a /non-deterministic/ set because we use it only to perform module +-- dependency analysis. +type ImpFVs = IdSet + -- | LocalFVs: set of variable that are: -- (a) bound locally (by a lambda, non-top-level let, or case); that is, -- it appears in the 'locals' field of 'Env' @@ -181,97 +193,100 @@ -- annBindingFreeVars :: Module -> StgBinding -> CgStgBinding -annBindingFreeVars this_mod = fstOf3 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet +annBindingFreeVars this_mod = fstOf4 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet -bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs) +bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, ImpFVs, TopFVs, LocalFVs) bindingFVs env body_fv b = case b of - StgNonRec bndr r -> (StgNonRec bndr r', fvs, lcl_fvs) + StgNonRec bndr r -> (StgNonRec bndr r', imp_fvs, top_fvs, lcl_fvs) where - (r', fvs, rhs_lcl_fvs) = rhsFVs env r + (r', imp_fvs, top_fvs, rhs_lcl_fvs) = rhsFVs env r lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs - StgRec pairs -> (StgRec pairs', fvs, lcl_fvss) + StgRec pairs -> (StgRec pairs', imp_fvs, top_fvs, lcl_fvss) where bndrs = map fst pairs env' = addLocals bndrs env - (rhss, rhs_fvss, rhs_lcl_fvss) = mapAndUnzip3 (rhsFVs env' . snd) pairs - fvs = unionVarSets rhs_fvss + (rhss, rhs_imp_fvss, rhs_top_fvss, rhs_lcl_fvss) = mapAndUnzip4 (rhsFVs env' . snd) pairs + top_fvs = unionVarSets rhs_top_fvss + imp_fvs = unionVarSets rhs_imp_fvss pairs' = zip bndrs rhss lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs -varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs) -varFVs env v (top_fvs, lcl_fvs) +varFVs :: Env -> Id -> (ImpFVs, TopFVs, LocalFVs) -> (ImpFVs, TopFVs, LocalFVs) +varFVs env v (imp_fvs, top_fvs, lcl_fvs) | v `elemVarSet` locals env -- v is locally bound - = (top_fvs, lcl_fvs `extendDVarSet` v) + = (imp_fvs, top_fvs, lcl_fvs `extendDVarSet` v) | nameIsLocalOrFrom (mod env) (idName v) -- v is bound at top level - = (top_fvs `extendVarSet` v, lcl_fvs) + = (imp_fvs, top_fvs `extendVarSet` v, lcl_fvs) | otherwise -- v is imported - = (top_fvs, lcl_fvs) + = (imp_fvs `extendVarSet` v, top_fvs, lcl_fvs) -exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs) +exprFVs :: Env -> StgExpr -> (CgStgExpr, ImpFVs, TopFVs, LocalFVs) exprFVs env = go where go (StgApp f as) - | (top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as) - = (StgApp f as, top_fvs, lcl_fvs) + | (imp_fvs, top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as) + = (StgApp f as, imp_fvs, top_fvs, lcl_fvs) - go (StgLit lit) = (StgLit lit, emptyVarSet, emptyDVarSet) + go (StgLit lit) = (StgLit lit, emptyVarSet, emptyVarSet, emptyDVarSet) go (StgConApp dc n as tys) - | (top_fvs, lcl_fvs) <- argsFVs env as - = (StgConApp dc n as tys, top_fvs, lcl_fvs) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as + = (StgConApp dc n as tys, imp_fvs, top_fvs, lcl_fvs) go (StgOpApp op as ty) - | (top_fvs, lcl_fvs) <- argsFVs env as - = (StgOpApp op as ty, top_fvs, lcl_fvs) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as + = (StgOpApp op as ty, imp_fvs, top_fvs, lcl_fvs) go (StgCase scrut bndr ty alts) - | (scrut',scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut - , (alts',alts_top_fvss,alts_lcl_fvss) - <- mapAndUnzip3 (altFVs (addLocals [bndr] env)) alts + | (scrut',scrut_imp_fvs,scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut + , (alts',alts_imp_fvss,alts_top_fvss,alts_lcl_fvss) + <- mapAndUnzip4 (altFVs (addLocals [bndr] env)) alts , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss + imp_fvs = scrut_imp_fvs `unionVarSet` unionVarSets alts_imp_fvss alts_lcl_fvs = unionDVarSets alts_lcl_fvss lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr - = (StgCase scrut' bndr ty alts', top_fvs,lcl_fvs) + = (StgCase scrut' bndr ty alts', imp_fvs, top_fvs, lcl_fvs) go (StgLet ext bind body) = go_bind (StgLet ext) bind body go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body go (StgTick tick e) - | (e', top_fvs, lcl_fvs) <- exprFVs env e + | (e', imp_fvs, top_fvs, lcl_fvs) <- exprFVs env e , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs - = (StgTick tick e', top_fvs, lcl_fvs') + = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') where tickish (Breakpoint _ _ ids) = mkDVarSet ids tickish _ = emptyDVarSet - go_bind dc bind body = (dc bind' body', top_fvs, lcl_fvs) + go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) where env' = addLocals (bindersOf bind) env - (body', body_top_fvs, body_lcl_fvs) = exprFVs env' body - (bind', bind_top_fvs, lcl_fvs) = bindingFVs env' body_lcl_fvs bind + (body', body_imp_fvs, body_top_fvs, body_lcl_fvs) = exprFVs env' body + (bind', bind_imp_fvs, bind_top_fvs, lcl_fvs) = bindingFVs env' body_lcl_fvs bind top_fvs = bind_top_fvs `unionVarSet` body_top_fvs + imp_fvs = bind_imp_fvs `unionVarSet` body_imp_fvs -rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs) -rhsFVs env (StgRhsClosure _ ccs uf bs body) - | (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body +rhsFVs :: Env -> StgRhs -> (CgStgRhs, ImpFVs, TopFVs, LocalFVs) +rhsFVs env (StgRhsClosure _ ccs uf bs body typ) + | (body', imp_fvs, top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body , let lcl_fvs' = delDVarSetList lcl_fvs bs - = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs') -rhsFVs env (StgRhsCon ccs dc mu ts bs) - | (top_fvs, lcl_fvs) <- argsFVs env bs - = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs) + = (StgRhsClosure lcl_fvs' ccs uf bs body' typ, imp_fvs, top_fvs, lcl_fvs') +rhsFVs env (StgRhsCon ccs dc mu ts bs typ) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env bs + = (StgRhsCon ccs dc mu ts bs typ, imp_fvs, top_fvs, lcl_fvs) -argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs) -argsFVs env = foldl' f (emptyVarSet, emptyDVarSet) +argsFVs :: Env -> [StgArg] -> (ImpFVs, TopFVs, LocalFVs) +argsFVs env = foldl' f (emptyVarSet, emptyVarSet, emptyDVarSet) where - f (fvs,ids) StgLitArg{} = (fvs, ids) - f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids) + f (imp_fvs,fvs,ids) StgLitArg{} = (imp_fvs, fvs, ids) + f (imp_fvs,fvs,ids) (StgVarArg v) = varFVs env v (imp_fvs, fvs, ids) -altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs) +altFVs :: Env -> StgAlt -> (CgStgAlt, ImpFVs, TopFVs, LocalFVs) altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e} - | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e + | (e', imp_fvs, top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e , let lcl_fvs' = delDVarSetList lcl_fvs bndrs , let newAlt = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'} - = (newAlt, top_fvs, lcl_fvs') + = (newAlt, imp_fvs, top_fvs, lcl_fvs') diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs --- a/compiler/GHC/Stg/InferTags.hs +++ b/compiler/GHC/Stg/InferTags.hs @@ -27,7 +27,7 @@ import GHC.Stg.InferTags.Rewrite (rewriteTopBinds) import Data.Maybe import GHC.Types.Name.Env (mkNameEnv, NameEnv) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Logger import qualified GHC.Unit.Types @@ -212,7 +212,7 @@ a) Tags for let-bindings: When compiling a binding for a constructor like `let x = Just True` - Weither or not `x` results in x pointing depends on the backend. + Whether `x` will be properly tagged depends on the backend. For the interpreter x points to a BCO which once evaluated returns a properly tagged pointer to the heap object. In the Cmm backend for the same binding we would allocate the constructor right @@ -481,7 +481,7 @@ initSig :: forall p. (Id, GenStgRhs p) -> TagSig -- Initial signature for the fixpoint loop initSig (_bndr, StgRhsCon {}) = TagSig TagTagged -initSig (bndr, StgRhsClosure _ _ _ _ _) = +initSig (bndr, StgRhsClosure _ _ _ _ _ _) = fromMaybe defaultSig (idTagSig_maybe bndr) where defaultSig = (TagSig TagTagged) @@ -516,13 +516,13 @@ -> TagEnv p -- ^ -> GenStgRhs p -- ^ -> (TagSig, GenStgRhs 'InferTaggedBinders) -inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body) +inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ) | isDeadEndId bnd_id && (notNull) bndrs -- See Note [Bottom functions are TagTagged] - = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body') + = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ) | otherwise = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ - (TagSig info', StgRhsClosure ext cc upd out_bndrs body') + (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ) where out_bndrs | Just marks <- idCbvMarks_maybe bnd_id @@ -553,11 +553,11 @@ | otherwise -> TagDunno in (id, TagSig tag) -inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args) +inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ) -- Constructors, which have untagged arguments to strict fields -- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno = --pprTrace "inferTagRhsCon" (ppr grp_ids) $ - (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args) + (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ) -- Adjust let semantics to the targeted backend. -- See Note [Tag inference for interpreted code] diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs --- a/compiler/GHC/Stg/InferTags/Rewrite.hs +++ b/compiler/GHC/Stg/InferTags/Rewrite.hs @@ -1,4 +1,4 @@ --- + -- Copyright (c) 2019 Andreas Klebinger -- @@ -22,8 +22,7 @@ import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Types.Basic ( CbvMark (..), isMarkedCbv - , TopLevelFlag(..), isTopLevel - , Levity(..) ) + , TopLevelFlag(..), isTopLevel ) import GHC.Types.Id import GHC.Types.Name import GHC.Types.Unique.Supply @@ -37,7 +36,7 @@ import GHC.Core.Type import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (mkLFImported) +import GHC.StgToCmm.Closure (importedIdLFInfo) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -258,7 +257,7 @@ (TagSig TagDunno) case nameIsLocalOrFrom this_mod (idName v) of True - | Just Unlifted <- typeLevity_maybe (idType v) + | definitelyUnliftedType (idType v) -- NB: v might be the Id of a representation-polymorphic join point, -- so we shouldn't use isUnliftedType here. See T22212. -> return True @@ -272,11 +271,11 @@ TagProper -> True TagTagged -> True TagTuple _ -> True -- Consider unboxed tuples tagged. - False -- Imported - -> return $! + -- Imported + False -> return $! -- Determine whether it is tagged from the LFInfo of the imported id. -- See Note [The LFInfo of Imported Ids] - case mkLFImported v of + case importedIdLFInfo v of -- Function, applied not entered. LFReEntrant {} -> True @@ -339,7 +338,7 @@ -- Rewrite a RHS rewriteRhs :: (Id,TagSig) -> InferStgRhs -> RM (TgStgRhs) -rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs_ #-} do +rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewriteRhs_ #-} do -- pprTraceM "rewriteRhs" (ppr _id) -- Look up the nodes representing the constructor arguments. @@ -355,7 +354,7 @@ let evalArgs = [v | StgVarArg v <- needsEval] :: [Id] if (null evalArgs) - then return $! (StgRhsCon ccs con cn ticks args) + then return $! (StgRhsCon ccs con cn ticks args typ) else do --assert not (isTaggedSig tagSig) -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id @@ -369,13 +368,14 @@ fvs <- fvArgs args -- lcls <- getFVs -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls) + -- We mark the closure updatable to retain sharing in the case that -- conExpr is an infinite recursive data type. See #23783. - return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) -rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do + return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ +rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do withBinders NotTopLevel args $ withClosureLcls fvs $ - StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body + StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ -- return (closure) fvArgs :: [StgArg] -> RM DVarSet diff --git a/compiler/GHC/Stg/InferTags/Types.hs b/compiler/GHC/Stg/InferTags/Types.hs --- a/compiler/GHC/Stg/InferTags/Types.hs +++ b/compiler/GHC/Stg/InferTags/Types.hs @@ -30,11 +30,6 @@ * * ********************************************************************* -} -type instance BinderP 'InferTaggedBinders = (Id, TagSig) -type instance XLet 'InferTaggedBinders = XLet 'CodeGen -type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen -type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen - type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders type InferStgBinding = GenStgBinding 'InferTaggedBinders type InferStgExpr = GenStgExpr 'InferTaggedBinders 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 @@ -198,20 +198,20 @@ -- as lambda binders, discarding all free vars. -> LlStgRhs -> LiftM OutStgRhs -liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args) +liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args typ) = assertPpr (isNothing mb_former_fvs) (text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) $ - StgRhsCon ccs con mn ts <$> traverse liftArgs args -liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = + StgRhsCon ccs con mn ts <$> traverse liftArgs args <*> pure typ +liftRhs Nothing (StgRhsClosure _ ccs upd infos body typ) = -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> - StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body -liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = + StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body <*> pure typ +liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body typ) = -- This RHS was lifted. Insert extra binders for @former_fvs@. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do let bndrs'' = dVarSetElems former_fvs ++ bndrs' - StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body + StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body <*> pure typ liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a 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 @@ -27,9 +27,13 @@ import GHC.Types.Basic import GHC.Types.Demand import GHC.Types.Id + import GHC.Runtime.Heap.Layout ( WordOff ) + import GHC.Stg.Lift.Config +import GHC.Stg.Lift.Types import GHC.Stg.Syntax + import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout @@ -110,80 +114,6 @@ llTrace _ _ c = c -- llTrace a b c = pprTrace a b c -type instance BinderP 'LiftLams = BinderInfo -type instance XRhsClosure 'LiftLams = DIdSet -type instance XLet 'LiftLams = Skeleton -type instance XLetNoEscape 'LiftLams = Skeleton - - --- | Captures details of the syntax tree relevant to the cost model, such as --- closures, multi-shot lambdas and case expressions. -data Skeleton - = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton - | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton - | AltSk !Skeleton !Skeleton - | BothSk !Skeleton !Skeleton - | NilSk - -bothSk :: Skeleton -> Skeleton -> Skeleton -bothSk NilSk b = b -bothSk a NilSk = a -bothSk a b = BothSk a b - -altSk :: Skeleton -> Skeleton -> Skeleton -altSk NilSk b = b -altSk a NilSk = a -altSk a b = AltSk a b - -rhsSk :: Card -> Skeleton -> Skeleton -rhsSk _ NilSk = NilSk -rhsSk body_dmd skel = RhsSk body_dmd skel - --- | The type used in binder positions in 'GenStgExpr's. -data BinderInfo - = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag - -- indicating whether it occurs as an argument - -- or in a nullary application - -- (see "GHC.Stg.Lift.Analysis#arg_occs"). - | BoringBinder !Id -- ^ Every other kind of binder - --- | Gets the bound 'Id' out a 'BinderInfo'. -binderInfoBndr :: BinderInfo -> Id -binderInfoBndr (BoringBinder bndr) = bndr -binderInfoBndr (BindsClosure bndr _) = bndr - --- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating --- occurrences as argument or in a nullary applications otherwise. -binderInfoOccursAsArg :: BinderInfo -> Maybe Bool -binderInfoOccursAsArg BoringBinder{} = Nothing -binderInfoOccursAsArg (BindsClosure _ b) = Just b - -instance Outputable Skeleton where - ppr NilSk = text "" - ppr (AltSk l r) = vcat - [ text "{ " <+> ppr l - , text "ALT" - , text " " <+> ppr r - , text "}" - ] - ppr (BothSk l r) = ppr l $$ ppr r - ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) - ppr (RhsSk card body) = hcat - [ lambda - , ppr card - , dot - , ppr body - ] - -instance Outputable BinderInfo where - ppr = ppr . binderInfoBndr - -instance OutputableBndr BinderInfo where - pprBndr b = pprBndr b . binderInfoBndr - pprPrefixOcc = pprPrefixOcc . binderInfoBndr - pprInfixOcc = pprInfixOcc . binderInfoBndr - bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr - mkArgOccs :: [StgArg] -> IdSet mkArgOccs = mkVarSet . mapMaybe stg_arg_var where @@ -311,10 +241,10 @@ bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs) tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs) -tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args) - = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args) -tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) - = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body') +tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args typ) + = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args typ) +tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body typ) + = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body' typ) where bndrs' = map BoringBinder bndrs (body_skel, body_arg_occs, body') = tagSkeletonExpr body @@ -400,7 +330,7 @@ -- We don't lift updatable thunks or constructors any_memoized = any is_memoized_rhs rhss is_memoized_rhs StgRhsCon{} = True - is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd + is_memoized_rhs (StgRhsClosure _ _ upd _ _ _) = isUpdatable upd -- Don't lift binders occurring as arguments. This would result in complex -- argument expressions which would have to be given a name, reintroducing @@ -469,7 +399,7 @@ rhsLambdaBndrs :: LlStgRhs -> [Id] rhsLambdaBndrs StgRhsCon{} = [] -rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs +rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _ _) = map binderInfoBndr bndrs -- | The size in words of a function closure closing over the given 'Id's, -- including the header. 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 @@ -197,12 +197,12 @@ -- | Omitting this makes for strange closure allocation schemes that crash the -- GC. removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass -removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body) +removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body typ) | isCurrentCCS ccs - = StgRhsClosure ext dontCareCCS upd bndrs body -removeRhsCCCS (StgRhsCon ccs con mu ts args) + = StgRhsClosure ext dontCareCCS upd bndrs body typ +removeRhsCCCS (StgRhsCon ccs con mu ts args typ) | isCurrentCCS ccs - = StgRhsCon dontCareCCS con mu ts args + = StgRhsCon dontCareCCS con mu ts args typ removeRhsCCCS rhs = rhs -- | The analysis monad consists of the following 'RWST' components: @@ -275,15 +275,13 @@ -- binder and fresh name generation. withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a withLiftedBndr abs_ids bndr inner = do - uniq <- getUniqueM let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr) let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) - let bndr' + bndr' <- -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. - = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal str uniq ManyTy - $ ty + transferPolyIdInfo bndr (dVarSetElems abs_ids) + <$> mkSysLocalM str ManyTy ty LiftM $ RWS.local (\e -> e { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e 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 @@ -149,7 +149,7 @@ Nothing -> return () Just msg -> do - logMsg logger Err.MCDump noSrcSpan + logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] in "GHC.Core.Lint" $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunit <+> text "***", @@ -247,25 +247,25 @@ opts <- getStgPprOpts let rhs' = pprStgRhs opts rhs case rhs of - StgRhsClosure _ ccs _ _ _ + StgRhsClosure _ ccs _ _ _ _ | isCurrentCCS ccs -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs') - StgRhsCon ccs _ _ _ _ + StgRhsCon ccs _ _ _ _ _ | isCurrentCCS ccs -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs') _ -> return () lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () -lintStgRhs (StgRhsClosure _ _ _ [] expr) +lintStgRhs (StgRhsClosure _ _ _ [] expr _) = lintStgExpr expr -lintStgRhs (StgRhsClosure _ _ _ binders expr) +lintStgRhs (StgRhsClosure _ _ _ binders expr _) = addLoc (LambdaBodyOf binders) $ addInScopeVars binders $ lintStgExpr expr -lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do +lintStgRhs rhs@(StgRhsCon _ con _ _ args _) = do opts <- getStgPprOpts when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ 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 @@ -33,6 +33,7 @@ import GHC.Utils.Error import GHC.Types.Var +import GHC.Types.Var.Set import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Logger @@ -41,8 +42,7 @@ import Control.Monad.Trans.Reader import GHC.Settings (Platform) import GHC.Stg.InferTags (inferTags) -import GHC.Types.Name.Env (NameEnv) -import GHC.Stg.InferTags.TagSig (TagSig) +import GHC.Stg.InferTags.TagSig ( StgCgInfos ) data StgPipelineOpts = StgPipelineOpts { stgPipeline_phases :: ![StgToDo] @@ -57,15 +57,11 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } deriving (Functor, Applicative, Monad, MonadIO) --- | Information to be exposed in interface files which is produced --- by the stg2stg passes. -type StgCgInfos = NameEnv TagSig - instance MonadUnique StgM where - getUniqueSupplyM = StgM $ do { tag <- ask - ; liftIO $! mkSplitUniqSupply tag} - getUniqueM = StgM $ do { tag <- ask - ; liftIO $! uniqFromTag tag} + getUniqueSupplyM = StgM $ do { mask <- ask + ; liftIO $! mkSplitUniqSupply mask} + getUniqueM = StgM $ do { mask <- ask + ; liftIO $! uniqFromMask mask} runStgM :: Char -> StgM a -> IO a runStgM mask (StgM m) = runReaderT m mask @@ -75,7 +71,7 @@ -> StgPipelineOpts -> Module -- ^ module being compiled -> [StgTopBinding] -- ^ input program - -> IO ([CgStgTopBinding], StgCgInfos) -- output program + -> IO ([(CgStgTopBinding,IdSet)], StgCgInfos) -- output program stg2stg logger extra_vars opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" @@ -93,9 +89,10 @@ -- sorting pass is necessary. -- This pass will also augment each closure with non-global free variables -- annotations (which is used by code generator to compute offsets into closures) - ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds' + ; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds') -- See Note [Tag inference for interactive contexts] - ; inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs + ; (cg_binds, cg_infos) <- inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs + ; pure (zip cg_binds imp_fvs, cg_infos) } where 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 @@ -122,10 +122,10 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv -statRhs top (_, StgRhsCon _ _ _ _ _) +statRhs top (_, StgRhsCon _ _ _ _ _ _) = countOne (ConstructorBinds top) -statRhs top (_, StgRhsClosure _ _ u _ body) +statRhs top (_, StgRhsClosure _ _ u _ body _) = statExpr body `combineSE` countOne ( case u of 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 @@ -480,14 +480,14 @@ = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs -unariseRhs rho (StgRhsClosure ext ccs update_flag args expr) +unariseRhs rho (StgRhsClosure ext ccs update_flag args expr typ) = do (rho', args1) <- unariseFunArgBinders rho args expr' <- unariseExpr rho' expr - return (StgRhsClosure ext ccs update_flag args1 expr') + return (StgRhsClosure ext ccs update_flag args1 expr' typ) -unariseRhs rho (StgRhsCon ccs con mu ts args) +unariseRhs rho (StgRhsCon ccs con mu ts args typ) = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) - return (StgRhsCon ccs con mu ts (unariseConArgs rho args)) + return (StgRhsCon ccs con mu ts (unariseConArgs rho args) typ) -------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -15,7 +15,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.ByteCode.Instr @@ -53,6 +53,7 @@ import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) import GHC.Utils.Error +import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic @@ -80,8 +81,10 @@ import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -239,7 +242,7 @@ -> Either [CgStgAlt] (CgStgRhs) -- ^ original expression; for debugging only -> Int -- ^ arity - -> Word16 -- ^ bitmap size + -> WordOff -- ^ bitmap size -> [StgWord] -- ^ bitmap -> Bool -- ^ True <=> is a return point, rather than a function -> [FFIInfo] @@ -249,7 +252,7 @@ protoBCOName = nm, protoBCOInstrs = maybe_with_stack_check, protoBCOBitmap = bitmap, - protoBCOBitmapSize = bitmap_size, + protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, protoBCOExpr = origin, protoBCOFFIs = ffis @@ -293,10 +296,10 @@ argBits _ [] = [] argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args - | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args + | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: [ArgRep] -> [ArgRep] -non_void = filter nv +non_void :: NonEmpty ArgRep -> [ArgRep] +non_void = NE.filter nv where nv V = False nv _ = True @@ -349,8 +352,8 @@ -- underlying expression collect :: CgStgRhs -> ([Var], CgStgExpr) -collect (StgRhsClosure _ _ _ args body) = (args, body) -collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args []) +collect (StgRhsClosure _ _ _ args body _) = (args, body) +collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args []) schemeR_wrk :: [Id] @@ -389,25 +392,24 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs) = do code <- schemeE d 0 p rhs cc_arr <- getCCArray + this_mod <- moduleName <$> getCurrentModule platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) - let breakInfo = dehydrateCgBreakInfo ty_vars idOffSets tick_ty + let toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty newBreakInfo tick_no breakInfo hsc_env <- getHscEnv let cc | Just interp <- hsc_interp hsc_env , interpreterProfiled interp = cc_arr ! tick_no | otherwise = toRemotePtr nullPtr - mb_mod_name <- getCurrentModuleName - case mb_mod_name of - Just mod_ptr -> do - let breakInstr = BRK_FUN (fromIntegral tick_no) mod_ptr cc - return $ breakInstr `consOL` code - Nothing -> return code + let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc + return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs -getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)] +getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] getVarOffSets platform depth env = map getOffSet where getOffSet id = case lookupBCEnv_maybe id env of @@ -420,23 +422,9 @@ -- this "adjustment" is needed due to stack manipulation for -- BRK_FUN in Interpreter.c In any case, this is used only when -- we trigger a breakpoint. - let !var_depth_ws = - trunc16W $ bytesToWords platform (depth - offset) + 2 + let !var_depth_ws = bytesToWords platform (depth - offset) + 2 in Just (id, var_depth_ws) -truncIntegral16 :: Integral a => a -> Word16 -truncIntegral16 w - | w > fromIntegral (maxBound :: Word16) - = panic "stack depth overflow" - | otherwise - = fromIntegral w - -trunc16B :: ByteOff -> Word16 -trunc16B = truncIntegral16 - -trunc16W :: WordOff -> Word16 -trunc16W = truncIntegral16 - fvsToEnv :: BCEnv -> CgStgRhs -> [Id] -- Takes the free variables of a right-hand side, and -- delivers an ordered list of the local variables that will @@ -466,7 +454,7 @@ StgLitArg lit -> typePrimRepArgs (literalType lit) StgVarArg i -> bcIdPrimReps i (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb reps + ret <- returnUnliftedReps d s szb (NE.toList $! reps) return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -493,7 +481,7 @@ PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE return ( mkSlideB platform szb (d - s) -- clear to sequel - `appOL` ret) -- go + `consOL` ret) -- go -- construct and return an unboxed tuple returnUnboxedTuple @@ -536,7 +524,7 @@ schemeE d s p (StgLetNoEscape xlet bnd body) = schemeE d s p (StgLet xlet bnd body) schemeE d s p (StgLet _xlet - (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args)) + (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args _typ)) body) = do -- Special case for a non-recursive let whose RHS is a -- saturated constructor application. @@ -557,7 +545,7 @@ fvss = map (fvsToEnv p') rhss -- Sizes of free vars - size_w = trunc16W . idSizeW platform + size_w = idSizeW platform sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss -- the arity of each rhs @@ -576,13 +564,13 @@ build_thunk :: StackDepth -> [Id] - -> Word16 + -> WordOff -> ProtoBCO Name - -> Word16 - -> Word16 + -> WordOff + -> HalfWord -> BcM BCInstrList build_thunk _ [] size bco off arity - = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) + = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) (fromIntegral size))) where mkap | arity == 0 = MKAP | otherwise = MKPAP @@ -594,9 +582,9 @@ alloc_code = toOL (zipWith mkAlloc sizes arities) where mkAlloc sz 0 - | is_tick = ALLOC_AP_NOUPD sz - | otherwise = ALLOC_AP sz - mkAlloc sz arity = ALLOC_PAP arity sz + | is_tick = ALLOC_AP_NOUPD (fromIntegral sz) + | otherwise = ALLOC_AP (fromIntegral sz) + mkAlloc sz arity = ALLOC_PAP arity (fromIntegral sz) is_tick = case binds of StgNonRec id _ -> occNameFS (getOccName id) == tickFS @@ -607,7 +595,7 @@ build_thunk d' fvs size bco off arity compile_binds = - [ compile_bind d' fvs x rhs size arity (trunc16W n) + [ compile_bind d' fvs x rhs size arity n | (fvs, x, rhs, size, arity, n) <- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] ] @@ -735,7 +723,7 @@ more_push_code <- do_pushery (d + arg_bytes) args return (push `appOL` more_push_code) do_pushery !d [] = do - let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d) + let !n_arg_words = bytesToWords platform (d - orig_d) return (unitOL (PACK con n_arg_words)) -- Push on the stack in the reverse order. @@ -761,7 +749,7 @@ platform <- profilePlatform <$> getProfile assert (sz == wordSize platform) return () let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s) - return (push_fn `appOL` (slide `appOL` unitOL ENTER)) + return (push_fn `appOL` (slide `consOL` unitOL ENTER)) do_pushes !d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps (these_args, rest_of_args) = splitAt n args @@ -866,7 +854,7 @@ (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -948,7 +936,7 @@ massert isAlgCase rhs_code <- schemeE stack_bot s p' rhs return (my_discr alt, - unitOL (UNPACK (trunc16W size)) `appOL` rhs_code) + unitOL (UNPACK size) `appOL` rhs_code) where real_bndrs = filterOut isTyVar bndrs @@ -1009,8 +997,9 @@ | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO | otherwise = ([], 0) - bitmap_size = trunc16W $ fromIntegral extra_slots + - bytesToWords platform (d - s) + bitmap_size :: WordOff + bitmap_size = fromIntegral extra_slots + + bytesToWords platform (d - s) bitmap_size' :: Int bitmap_size' = fromIntegral bitmap_size @@ -1028,15 +1017,15 @@ isUnboxedSumType (idType id) = Nothing | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset) | otherwise = Nothing - where rel_offset = trunc16W $ bytesToWords platform (d - offset) + where rel_offset = bytesToWords platform (d - offset) - bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers + bitmap = intsToReverseBitmap platform bitmap_size' pointers alt_stuff <- mapM codeAlt alts alt_final0 <- mkMultiBranch maybe_ncons alt_stuff let alt_final - | ubx_tuple_frame = mkSlideW 0 2 `mappend` alt_final0 + | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0 | otherwise = alt_final0 let @@ -1089,9 +1078,6 @@ reg_order :: GlobalReg -> (Int, GlobalReg) reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg) - -- a VanillaReg goes to the same place regardless of whether it - -- contains a pointer - reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr) -- if we don't have a position for a FloatReg then they must be passed -- in the equivalent DoubleReg reg_order (FloatReg n) = reg_order (DoubleReg n) @@ -1309,11 +1295,11 @@ -- ^ The stack layout of the arguments, where each offset is relative to the -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned, -- and the list must be sorted in order of ascending offset (i.e. bottom to top). - -> (Word16, [StgWord]) + -> (WordOff, [StgWord]) mkStackBitmap platform nptrs_prefix args_info args = (bitmap_size, bitmap) where - bitmap_size = trunc16W $ nptrs_prefix + arg_bottom + bitmap_size = nptrs_prefix + arg_bottom bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets arg_bottom = nativeCallSize args_info @@ -1387,7 +1373,7 @@ (push_target `consOL` push_info `consOL` PUSH_BCO args_bco `consOL` - (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL)) + (mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL)) -- ----------------------------------------------------------------------------- -- Deal with a CCall. @@ -1555,7 +1541,7 @@ push_r = if returns_void then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW)) + else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) -- generate the marshalling code we're going to call @@ -1563,7 +1549,7 @@ -- instruction needs to describe the chunk of stack containing -- the ccall args to the GC, so it needs to know how large it -- is. See comment in Interpreter.c with the CCALL instruction. - stk_offset = trunc16W $ bytesToWords platform (d_after_r - s) + stk_offset = bytesToWords platform (d_after_r - s) conv = case cconv of CCallConv -> FFICCall @@ -1592,7 +1578,7 @@ -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) - wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW) + wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) `snocOL` RETURN (toArgRep platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( @@ -1617,8 +1603,7 @@ AddrRep -> FFIPointer FloatRep -> FFIFloat DoubleRep -> FFIDouble - LiftedRep -> FFIPointer - UnliftedRep -> FFIPointer + BoxedRep _ -> FFIPointer _ -> pprPanic "primRepToFFIType" (ppr r) where (signed_word, unsigned_word) = case platformWordSize platform of @@ -1643,9 +1628,8 @@ AddrRep -> LitNullAddr DoubleRep -> LitDouble 0 FloatRep -> LitFloat 0 - LiftedRep -> LitNullAddr - UnliftedRep -> LitNullAddr - _ -> pprPanic "mkDummyLiteral" (ppr pr) + BoxedRep _ -> LitNullAddr + _ -> pprPanic "mkDummyLiteral" (ppr pr) -- Convert (eg) @@ -1673,9 +1657,8 @@ (pprType fn_ty) in case r_reps of - [] -> panic "empty typePrimRepArgs" - [VoidRep] -> Nothing - [rep] -> Just rep + VoidRep :| [] -> Nothing + rep :| [] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -1797,8 +1780,9 @@ = do platform <- targetPlatform <$> getDynFlags let !szb = idSizeCon platform var + with_instr :: (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff) with_instr instr = do - let !off_b = trunc16B $ d - d_v + let !off_b = d - d_v return (unitOL (instr off_b), wordSize platform) case szb of @@ -1807,7 +1791,7 @@ 4 -> with_instr PUSH32_W _ -> do let !szw = bytesToWords platform szb - !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1 + !off_w = bytesToWords platform (d - d_v) + szw - 1 return (toOL (genericReplicate szw (PUSH_L off_w)), wordsToBytes platform szw) -- d - d_v offset from TOS to the first slot of the object @@ -1868,7 +1852,7 @@ 1 -> PUSH_UBX8 lit 2 -> PUSH_UBX16 lit 4 -> PUSH_UBX32 lit - _ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes) + _ -> PUSH_UBX lit (bytesToWords platform size_bytes) case lit of LitLabel {} -> code AddrRep @@ -1907,7 +1891,7 @@ platform <- targetPlatform <$> getDynFlags let !szb = idSizeCon platform v done instr = do - let !off = trunc16B $ d - d_v + let !off = d - d_v return (unitOL (instr off), szb) case szb of 1 -> done PUSH8 @@ -1972,8 +1956,7 @@ mkTree vals range_lo range_hi = let n = length vals `div` 2 - vals_lo = take n vals - vals_hi = drop n vals + (vals_lo, vals_hi) = splitAt n vals v_mid = fst (head vals_hi) in do label_geq <- getLabelBc @@ -2119,7 +2102,7 @@ isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - bcIdPrimReps $ var + NE.toList . bcIdPrimReps $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2127,13 +2110,13 @@ bcIdPrimRep :: Id -> PrimRep bcIdPrimRep id - | [rep] <- typePrimRepArgs (idType id) + | rep :| [] <- typePrimRepArgs (idType id) = rep | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) -bcIdPrimReps :: Id -> [PrimRep] +bcIdPrimReps :: Id -> NonEmpty PrimRep bcIdPrimReps id = typePrimRepArgs (idType id) repSizeWords :: Platform -> PrimRep -> WordOff @@ -2158,26 +2141,21 @@ ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) -mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr -mkSlideB platform !nb !db = mkSlideW n d +mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr +mkSlideB platform nb db = SLIDE n d where - !n = trunc16W $ bytesToWords platform nb + !n = bytesToWords platform nb !d = bytesToWords platform db -mkSlideW :: Word16 -> WordOff -> OrdList BCInstr +mkSlideW :: WordOff -> WordOff -> OrdList BCInstr mkSlideW !n !ws - | ws > fromIntegral limit - -- If the amount to slide doesn't fit in a Word16, generate multiple slide - -- instructions - = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit) | ws == 0 = nilOL | otherwise = unitOL (SLIDE n $ fromIntegral ws) - where - limit :: Word16 - limit = maxBound + + atomPrimRep :: StgArg -> PrimRep atomPrimRep (StgVarArg v) = bcIdPrimRep v atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) @@ -2191,8 +2169,8 @@ mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> [ArgRep] -typeArgReps platform = map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> NonEmpty ArgRep +typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs -- ----------------------------------------------------------------------------- -- The bytecode generator's monad @@ -2285,8 +2263,8 @@ newBreakInfo ix info = BcM $ \st -> return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) -getCurrentModuleName :: BcM (Maybe (RemotePtr ModuleName)) -getCurrentModuleName = BcM $ \st -> return (st, modBreaks_module <$> modBreaks st) +getCurrentModule :: BcM Module +getCurrentModule = BcM $ \st -> return (st, thisModule st) tickFS :: FastString tickFS = fsLit "ticked" diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -199,12 +199,12 @@ cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args) +cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args _typ) = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body) +cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body _typ) = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $ -- There should be no free variables cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body @@ -272,9 +272,10 @@ -- return it. -- NB 2: We don't set CC when entering data (WDP 94/06) do { tickyEnterDynCon - ; ldvEnter (CmmReg nodeReg) + ; let node = CmmReg $ nodeReg platform + ; ldvEnter node ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)] + ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)] } -- The case continuation code expects a tagged pointer } diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -69,8 +69,7 @@ toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of VoidRep -> V - LiftedRep -> P - UnliftedRep -> P + BoxedRep _ -> P IntRep -> N WordRep -> N Int8Rep -> N -- Gets widened to native word width for calls 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 @@ -250,14 +250,14 @@ -- (see above) ) -cgRhs id (StgRhsCon cc con mn _ts args) +cgRhs id (StgRhsCon cc con mn _ts args _typ) = withNewTickyCounterCon id con mn $ buildDynCon id mn True cc con (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} -cgRhs id (StgRhsClosure fvs cc upd_flag args body) +cgRhs id (StgRhsClosure fvs cc upd_flag args body _typ) = do profile <- getProfile check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig @@ -424,7 +424,7 @@ -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - ; let use_cc = cccsExpr; blame_cc = cccsExpr + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) ; let info_tbl = mkCmmInfo closure_info bndr currentCCS @@ -465,7 +465,7 @@ descr -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body - ; let use_cc = cccsExpr; blame_cc = cccsExpr + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform -- BUILD THE OBJECT @@ -553,13 +553,7 @@ -- Extend reader monad with information that -- self-recursive tail calls can be optimized into local -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr. - ; let !self_loop_info = MkSelfLoopInfo - { sli_id = bndr - , sli_arity = arity - , sli_header_block = loop_header_id - , sli_registers = arg_regs - } - ; withSelfLoop self_loop_info $ do + ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do { -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do @@ -640,6 +634,7 @@ -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body = do { profile <- getProfile + ; platform <- getPlatform ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling @@ -658,7 +653,7 @@ -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { enterCostCentreThunk (CmmReg nodeReg) + do { enterCostCentreThunk (CmmReg $ nodeReg platform) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details ; load_fvs node lf_info fv_bindings @@ -707,19 +702,11 @@ when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitAtomicStore platform MemOrderRelease - (cmmOffsetW platform node (fixedHdrSizeW profile)) - currentTSOExpr + emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - emitAtomicStore platform MemOrderRelease - node - (CmmReg (CmmGlobal EagerBlackholeInfo)) - -emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () -emitAtomicStore platform mord addr val = - emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] - where - w = typeWidth $ cmmExprType platform val + let w = wordWidth platform + emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) + [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), @@ -805,7 +792,7 @@ ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl - [ (baseExpr, AddrHint), + [ (baseExpr platform, AddrHint), (CmmReg (CmmLocal node), AddrHint) ] False diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -33,17 +33,17 @@ baseRegOffset :: Platform -> GlobalReg -> Int baseRegOffset platform reg = case reg of - VanillaReg 1 _ -> pc_OFFSET_StgRegTable_rR1 constants - VanillaReg 2 _ -> pc_OFFSET_StgRegTable_rR2 constants - VanillaReg 3 _ -> pc_OFFSET_StgRegTable_rR3 constants - VanillaReg 4 _ -> pc_OFFSET_StgRegTable_rR4 constants - VanillaReg 5 _ -> pc_OFFSET_StgRegTable_rR5 constants - VanillaReg 6 _ -> pc_OFFSET_StgRegTable_rR6 constants - VanillaReg 7 _ -> pc_OFFSET_StgRegTable_rR7 constants - VanillaReg 8 _ -> pc_OFFSET_StgRegTable_rR8 constants - VanillaReg 9 _ -> pc_OFFSET_StgRegTable_rR9 constants - VanillaReg 10 _ -> pc_OFFSET_StgRegTable_rR10 constants - VanillaReg n _ -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") + VanillaReg 1 -> pc_OFFSET_StgRegTable_rR1 constants + VanillaReg 2 -> pc_OFFSET_StgRegTable_rR2 constants + VanillaReg 3 -> pc_OFFSET_StgRegTable_rR3 constants + VanillaReg 4 -> pc_OFFSET_StgRegTable_rR4 constants + VanillaReg 5 -> pc_OFFSET_StgRegTable_rR5 constants + VanillaReg 6 -> pc_OFFSET_StgRegTable_rR6 constants + VanillaReg 7 -> pc_OFFSET_StgRegTable_rR7 constants + VanillaReg 8 -> pc_OFFSET_StgRegTable_rR8 constants + VanillaReg 9 -> pc_OFFSET_StgRegTable_rR9 constants + VanillaReg 10 -> pc_OFFSET_StgRegTable_rR10 constants + VanillaReg n -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") FloatReg 1 -> pc_OFFSET_StgRegTable_rF1 constants FloatReg 2 -> pc_OFFSET_StgRegTable_rF2 constants FloatReg 3 -> pc_OFFSET_StgRegTable_rF3 constants @@ -124,7 +124,7 @@ get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr get_Regtable_addr_from_offset platform offset = if haveRegBase platform - then cmmRegOff baseReg offset + then cmmRegOff (baseReg platform) offset else regTableOffset platform offset -- | Fixup global registers so that they assign to locations within the @@ -144,47 +144,49 @@ where fixAssign stmt = case stmt of - CmmAssign (CmmGlobal reg) src + CmmAssign (CmmGlobal reg_use) src -- MachSp isn't an STG register; it's merely here for tracking unwind -- information | reg == MachSp -> stmt | otherwise -> let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of - True -> CmmAssign (CmmGlobal reg) src + True -> CmmAssign (CmmGlobal reg_use) src False -> CmmStore baseAddr src NaturallyAligned + where reg = globalRegUseGlobalReg reg_use other_stmt -> other_stmt fixExpr expr = case expr of -- MachSp isn't an STG; it's merely here for tracking unwind information - CmmReg (CmmGlobal MachSp) -> expr - CmmReg (CmmGlobal reg) -> + CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr + CmmReg (CmmGlobal reg_use) -> -- Replace register leaves with appropriate StixTrees for -- the given target. MagicIds which map to a reg on this -- arch are left unchanged. For the rest, BaseReg is taken -- to mean the address of the reg table in MainCapability, -- and for all others we generate an indirection to its -- location in the register table. + let reg = globalRegUseGlobalReg reg_use in case reg `elem` activeStgRegs platform of True -> expr False -> let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr - _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned + _other -> CmmLoad baseAddr + (globalRegSpillType platform reg) + NaturallyAligned - CmmRegOff greg@(CmmGlobal reg) offset -> + CmmRegOff (CmmGlobal reg_use) offset -> -- RegOf leaves are just a shorthand form. If the reg maps -- to a real reg, we keep the shorthand, otherwise, we just -- expand it and defer to the above code. - -- NB: to ensure type correctness we need to ensure the Add - -- as well as the Int need to be of the same size as the - -- register. + let reg = globalRegUseGlobalReg reg_use in case reg `elem` activeStgRegs platform of True -> expr - False -> CmmMachOp (MO_Add (cmmRegWidth platform greg)) [ - fixExpr (CmmReg greg), + False -> CmmMachOp (MO_Add (wordWidth platform)) [ + fixExpr (CmmReg (CmmGlobal reg_use)), CmmLit (CmmInt (fromIntegral offset) - (cmmRegWidth platform greg))] + (wordWidth platform))] other_expr -> other_expr 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 @@ -28,7 +28,7 @@ LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkApLFInfo, importedIdLFInfo, mkLFArgument, mkLFLetNoEscape, mkLFStringLit, lfDynTag, isLFThunk, isLFReEntrant, lfUpdatable, @@ -95,6 +95,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Utils.Misc +import GHC.Data.Maybe (isNothing) import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -254,130 +256,67 @@ (mightBeFunTy (idType id)) ------------- -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id = +-- | The 'LambdaFormInfo' of an imported Id. +-- See Note [The LFInfo of Imported Ids] +importedIdLFInfo :: Id -> LambdaFormInfo +importedIdLFInfo id = -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types case idLFInfo_maybe id of Just lf_info -> - -- Use the LambdaFormInfo from the interface + -- Use the existing LambdaFormInfo lf_info Nothing - -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type. - -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed! + -- Doesn't have a LambdaFormInfo, but we know it must be 'LFReEntrant' from its arity | arity > 0 -> LFReEntrant TopLevel arity True ArgUnknown - | Just con <- isDataConId_maybe id - -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types - -- and Note [The LFInfo of Imported Ids] below - -> assert (hasNoNonZeroWidthArgs con) $ - LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor - + -- We can't be sure of the LambdaFormInfo of this imported Id, + -- so make a conservative one from the type. | otherwise - -> mkLFArgument id -- Not sure of exact arity + -> assert (isNothing (isDataConId_maybe id)) $ -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make + mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id - hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys {- Note [The LFInfo of Imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Conveying CAF-info and LFInfo between modules] and -Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the -LambdaFormInfo records the details of a closure representation and is often, -when optimisations are enabled, serialized to the interface of a module. +As explained in Note [Conveying CAF-info and LFInfo between modules] +the LambdaFormInfo records the details of a closure representation and is +often, when optimisations are enabled, serialized to the interface of a module. -In particular, the `lfInfo` field of the `IdInfo` field of an `Id` -* For Ids defined in this module: is `Nothing` -* For imported Ids: +In particular, the `lfInfo` field of the `IdInfo` field of an `Id`: +* For DataCon workers and wrappers is populated as described in +Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make +* For other Ids defined in the module being compiled: is `Nothing` +* For other imported Ids: * is (Just lf_info) if the LFInfo was serialised into the interface file (typically, when the exporting module was compiled with -O) * is Nothing if it wasn't serialised -However, when an interface doesn't have a LambdaFormInfo for some imported Id -(so that its `lfInfo` field is `Nothing`), we can conservatively create one -using `mkLFImported`. - The LambdaFormInfo we give an Id is used in determining how to tag its pointer -(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as -faithfully as possible or otherwise risk having pointers incorrectly tagged, -which can lead to performance issues and even segmentation faults (see #23231 -and #23146). In particular, saturated data constructor applications *must* be -unambiguously given `LFCon`, and the invariant - - If the LFInfo (serialised or built with mkLFImported) says LFCon, then it - really is a static data constructor, and similar for LFReEntrant - -must be upheld. - -In `mkLFImported`, we make a conservative approximation to the real -LambdaFormInfo as follows: - -(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are -tagged (by `litIdInfo`) with the corresponding arity. - - This is also true of data con wrappers and workers with arity > 0, - regardless of the runtime relevance of the arguments - - For example, `Just :: a -> Maybe a` is given `LFReEntrant` - and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too - -(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because -they are fully saturated data constructor applications and pointers to them -should be tagged with the constructor index. - -(2.1) A datacon *wrapper* with zero arity must be a fully saturated application -of the worker to zero-width arguments only (which are dropped after unarisation) - -(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes -no arguments whatsoever (not even zero-width args) - -To ensure we properly give `LFReEntrant` to data constructors with some arity, -and `LFCon` only to data constructors with zero arity, we must first check for -`arity > 0` and only afterwards `isDataConId` -- the order of the guards in -`mkLFImported` is quite important. - -As an example, consider the following data constructors: - - data T1 a where - TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a - - data T2 a where - TCon2 :: {-# UNPACK #-} !() -> T2 a - - data T3 a where - TCon3 :: T3 '[] - -`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while -the worker has an unlifted equality argument, which is zero-width. - -`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width, -while the worker has no arguments. - -`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument; -their Core representation: - - $WTCon3 :: T3 '[] - $WTCon3 = TCon3 @[] - - TCon3 :: forall (a :: * -> *). (a ~# []) => T a - TCon3 = /\a. \(co :: a~#[]). TCon3 co - -For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they -both have arity == 1. +(see `litIdInfo` and `lfDynTag`). Therefore, it's crucial we attribute a correct +LambdaFormInfo to imported Ids, or otherwise risk having pointers incorrectly +tagged which can lead to performance issues and even segmentation faults (see +#23231 and Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]). -For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 -while the worker is `LFCon` since its arity == 0 +In particular, saturated data constructor applications *must* be unambiguously +given `LFCon`, and if the LFInfo says LFCon, then it really is a static data +constructor, and similar for LFReEntrant. -For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the -worker `LFReEntrant` since its arity == 1 +In `importedIdLFInfo`, we construct a LambdaFormInfo for imported Ids as follows: -One might think we could give *workers* with only zero-width-args the `LFCon` -LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. -However, these workers, albeit rarely used, are unambiguously functions --- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. -See also the discussion in #23158. +(1) If the `lfInfo` field contains an LFInfo, we use that LFInfo which is +correct by construction (the invariant being that if it exists, it is correct): + (1.1) Either it was serialised to the interface we're importing the Id from, + (1.2) Or it's a DataCon worker or wrapper and its LFInfo was constructed + according to Note [LFInfo of DataCon workers and wrappers] +(2) When the `lfInfo` field is `Nothing` + (2.1) If the `idFunRepArity` of the Id is known and is greater than 0, then + the Id is unambiguously a function and is given `LFReEntrant`, and pointers + to this Id will be tagged (by `litIdInfo`) with the corresponding arity. + (2.2) Otherwise, we can make a conservative estimate from the type. -} @@ -600,12 +539,12 @@ getCallMethod :: StgToCmmConfig -> Name -- Function being applied - -> Id -- Function Id used to check if it can refer to + -> Id -- Function Id used to chech if it can refer to -- CAF's and whether the function is tail-calling -- itself -> LambdaFormInfo -- Its info -> RepArity -- Number of available arguments - -- (including void args) + -> RepArity -- Number of them being void arguments -> CgLoc -- Passed in from cgIdApp so that we can -- handle let-no-escape bindings and self-recursive -- tail calls using the same data constructor, @@ -614,22 +553,19 @@ -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call -> CallMethod -getCallMethod cfg _ id _ n_args _cg_loc (Just self_loop) +getCallMethod cfg _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args)) | stgToCmmLoopification cfg - , MkSelfLoopInfo - { sli_id = loop_id, sli_arity = arity - , sli_header_block = blk_id, sli_registers = arg_regs - } <- self_loop - , id == loop_id - , n_args == arity + , id == self_loop_id + , args `lengthIs` (n_args - v_args) -- If these patterns match then we know that: -- * loopification optimisation is turned on -- * function is performing a self-recursive call in a tail position - -- * number of parameters matches the function's arity. - -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr for more details - = JumpToIt blk_id arg_regs + -- * number of non-void parameters of the function matches functions arity. + -- See Note [Self-recursive tail calls] and Note [Void arguments in + -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details + = JumpToIt block_id args -getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info +getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all && not (profileIsProfiling (stgToCmmProfile cfg)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm @@ -637,16 +573,16 @@ | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity -getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info +getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt -getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info +getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) - n_args _cg_loc _self_loop_info + n_args _v_args _cg_loc _self_loop_info | Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference @@ -684,7 +620,7 @@ updatable) 0 -- Imported(Unknown) Ids -getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info +getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info | n_args == 0 , Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference @@ -701,14 +637,14 @@ EnterIt -- Not a function -- TODO: Redundant with above match? --- getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info +-- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info -- = assertPpr (n_args == 0) (ppr name <+> ppr n_args) -- EnterIt -- Not a function -getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info +getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs -getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method" +getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" ----------------------------------------------------------------------------- -- Data types for closure information 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 @@ -215,11 +215,12 @@ ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $ text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args) ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info - use_cc blame_cc args_w_offsets + (use_cc platform) (blame_cc platform) + args_w_offsets ; return (mkRhsInit platform reg lf_info hp_plus_n) } where - use_cc -- cost-centre to stick in the object - | isCurrentCCS ccs = cccsExpr + use_cc platform -- cost-centre to stick in the object + | isCurrentCCS ccs = cccsExpr platform | otherwise = panic "buildDynCon: non-current CCS not implemented" blame_cc = use_cc -- cost-centre on which to blame the alloc (same) 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 @@ -149,7 +149,7 @@ | otherwise = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) in return $ - litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (importedIdLFInfo id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug, id is neither in local binds nor is external }}} 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 @@ -200,9 +200,9 @@ -> Id -> CgStgRhs -> FCode (CgIdInfo, FCode ()) -cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body _typ) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body -cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args _typ) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $ text "StgRhsCon doesn't have type args")) @@ -222,12 +222,11 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do platform <- getPlatform + let code = forkLneBody $ withNewTickyCounterLNE bndr args $ do + { restoreCurrentCostCentre platform cc_slot + ; arg_regs <- bindArgsToRegs args + ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } return ( lneIdInfo platform bndr args, code ) - where - code = forkLneBody $ withNewTickyCounterLNE bndr args $ do - { restoreCurrentCostCentre cc_slot - ; arg_regs <- bindArgsToRegs args - ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } ------------------------------------------------------------------------ @@ -519,7 +518,7 @@ ; mb_cc <- maybeSaveCostCentre True ; _ <- withSequel (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + ; restoreCurrentCostCentre platform mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newBlockId ; emitLabel l @@ -568,7 +567,7 @@ ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -} ; ret_kind <- withSequel sequel (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + ; restoreCurrentCostCentre platform mb_cc ; _ <- bindArgsToRegs ret_bndrs ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts } @@ -1003,7 +1002,8 @@ fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args - case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of + v_args = length $ filter (isZeroBitTy . stgArgType) args + case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of -- A value in WHNF, so we can just return it. ReturnIt | isZeroBitTy (idType fun_id) -> emitReturn [] @@ -1098,14 +1098,12 @@ -- -- Implementation is spread across a couple of places in the code: -- --- * FCode monad stores additional information in its reader --- environment (stgToCmmSelfLoop field). This `SelfLoopInfo` --- record tells us which function can tail call itself in an --- optimized way (it is the function currently being compiled), --- its RepArity, what is the label of its loop header (L1 in --- example above) and information about which local registers --- should receive arguments when making a call (this would be a --- and b in the example above). +-- * FCode monad stores additional information in its reader environment +-- (stgToCmmSelfLoop field). This information tells us which function can +-- tail call itself in an optimized way (it is the function currently +-- being compiled), what is the label of a loop header (L1 in example above) +-- and information about local registers in which we should arguments +-- before making a call (this would be a and b in example above). -- -- * Whenever we are compiling a function, we set that information to reflect -- the fact that function currently being compiled can be jumped to, instead @@ -1129,13 +1127,36 @@ -- of call will be generated. getCallMethod decides to generate a self -- recursive tail call when (a) environment stores information about -- possible self tail-call; (b) that tail call is to a function currently --- being compiled; (c) number of passed arguments is equal to --- function's unarised arity. (d) loopification is turned on via --- -floopification command-line option. +-- being compiled; (c) number of passed non-void arguments is equal to +-- function's arity. (d) loopification is turned on via -floopification +-- command-line option. -- -- * Command line option to turn loopification on and off is implemented in -- DynFlags, then passed to StgToCmmConfig for this phase. - +-- +-- +-- Note [Void arguments in self-recursive tail calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- State# tokens can get in the way of the loopification optimization as seen in +-- #11372. Consider this: +-- +-- foo :: [a] +-- -> (a -> State# s -> (# State s, Bool #)) +-- -> State# s +-- -> (# State# s, Maybe a #) +-- foo [] f s = (# s, Nothing #) +-- foo (x:xs) f s = case f x s of +-- (# s', b #) -> case b of +-- True -> (# s', Just x #) +-- False -> foo xs f s' +-- +-- We would like to compile the call to foo as a local jump instead of a call +-- (see Note [Self-recursive tail calls]). However, the generated function has +-- an arity of 2 while we apply it to 3 arguments, one of them being of void +-- type. Thus, we mustn't count arguments of void type when checking whether +-- we can turn a call into a self-recursive jump. +-- emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do @@ -1157,7 +1178,7 @@ Return -> do { let entry = entryCode platform $ closureInfoPtr platform align_check - $ CmmReg nodeReg + $ CmmReg (nodeReg platform) ; emit $ mkJump profile NativeNodeCall entry [cmmUntag platform fun] updfr_off ; return AssignedDirectly @@ -1200,12 +1221,13 @@ -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg)) + ; let node = CmmReg $ nodeReg platform + entry = entryCode platform (closureInfoPtr platform align_check node) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ copyout <*> - mkCbranch (cmmIsTagged platform (CmmReg nodeReg)) + mkCbranch (cmmIsTagged platform node) lret lcall Nothing <*> outOfLine lcall (the_call,tscope) <*> mkLabel lret tscope <*> diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -315,7 +315,7 @@ close_nursery <- closeNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr + mkAssign (CmmLocal tso) (currentTSOExpr platform) , -- tso->stackobj->sp = Sp; mkStore (cmmOffset platform @@ -323,13 +323,14 @@ (CmmReg (CmmLocal tso)) (tso_stackobj profile))) (stack_SP profile)) - spExpr + (spExpr platform) , close_nursery , -- and save the current cost centre stack in the TSO when profiling: if profileIsProfiling profile - then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr + then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) + (cccsExpr platform) else mkNop ] @@ -388,14 +389,14 @@ let mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) live = cmmAndWord platform regs_live mask cond = cmmNeWord platform live (zeroExpr platform) - reg_ty = cmmRegType platform (CmmGlobal reg) + reg_ty = globalRegSpillType platform reg width = roundUpToWords platform (widthInBytes $ typeWidth reg_ty) - adj_sp = mkAssign spReg - (cmmOffset platform spExpr (negate width)) - save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) (negate width)) + save_reg = mkStore (spExpr platform) (CmmReg $ CmmGlobal $ GlobalRegUse reg reg_ty) in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg] - emit . catAGraphs =<< mapM save_arg (reverse regs) + emit . catAGraphs =<< mapM save_arg (reverse $ regs) -- | Pop a subset of STG registers from the stack (see 'emitPushArgRegs') emitPopArgRegs :: CmmExpr -> FCode () @@ -406,12 +407,13 @@ let mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) live = cmmAndWord platform regs_live mask cond = cmmNeWord platform live (zeroExpr platform) - reg_ty = cmmRegType platform (CmmGlobal reg) + reg_ty = globalRegSpillType platform reg width = roundUpToWords platform (widthInBytes $ typeWidth reg_ty) - adj_sp = mkAssign spReg - (cmmOffset platform spExpr width) - restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty NaturallyAligned) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) width) + restore_reg = mkAssign (CmmGlobal $ GlobalRegUse reg reg_ty) + (CmmLoad (spExpr platform) reg_ty NaturallyAligned) in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp] emit . catAGraphs =<< mapM save_arg regs @@ -422,7 +424,7 @@ let platform = profilePlatform profile tso <- newTemp (bWord platform) code <- closeNursery profile tso - emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code {- | @closeNursery dflags tso@ produces code to close the nursery. @@ -451,14 +453,14 @@ platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ - mkAssign cnreg currentNurseryExpr, + mkAssign cnreg (currentNurseryExpr platform), -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1), + mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform (hpExpr platform) 1), let alloc = CmmMachOp (mo_wordSub platform) - [ cmmOffsetW platform hpExpr 1 + [ cmmOffsetW platform (hpExpr platform) 1 , cmmLoadBWord platform (nursery_bdescr_start platform cnreg) ] @@ -486,23 +488,23 @@ open_nursery <- openNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr, + mkAssign (CmmLocal tso) (currentTSOExpr platform), -- stack = tso->stackobj; mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))), -- Sp = stack->sp; - mkAssign spReg (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), + mkAssign (spReg platform) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) + mkAssign (spLimReg platform) (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) (pc_RESERVED_STACK_WORDS (platformConstants platform))), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - mkAssign hpAllocReg (zeroExpr platform), + mkAssign (hpAllocReg platform) (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: if profileIsProfiling profile then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile) - in storeCurCCS (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) + in storeCurCCS platform (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) else mkNop ] @@ -513,7 +515,7 @@ let platform = profilePlatform profile tso <- newTemp (bWord platform) code <- openNursery profile tso - emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code {- | @openNursery profile tso@ produces code to open the nursery. A local register @@ -556,17 +558,17 @@ -- what code we generate, look at the assembly for -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ - mkAssign cnreg currentNurseryExpr, + mkAssign cnreg (currentNurseryExpr platform), mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)), -- Hp = CurrentNursery->free - 1; - mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), + mkAssign (hpReg platform) (cmmOffsetW platform (CmmReg bdfreereg) (-1)), mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - mkAssign hpLimReg + mkAssign (hpLimReg platform) (cmmOffsetExpr platform (CmmReg bdstartreg) (cmmOffset platform diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -353,11 +353,12 @@ -> FCode () entryHeapCheck' is_fastf node arity args code = do profile <- getProfile - let is_thunk = arity == 0 + let platform = profilePlatform profile + is_thunk = arity == 0 args' = map (CmmReg . CmmLocal) args - stg_gc_fun = CmmReg (CmmGlobal GCFun) - stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) + stg_gc_fun = CmmReg (CmmGlobal $ GlobalRegUse GCFun $ bWord platform) + stg_gc_enter1 = CmmReg (CmmGlobal $ GlobalRegUse GCEnter1 $ bWord platform) {- Thunks: jump stg_gc_enter_1 @@ -615,14 +616,14 @@ -- See Note [Single stack check] sp_oflo sp_hwm = CmmMachOp (mo_wordULt platform) - [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg))) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType $ spReg platform))) [CmmStackSlot Old 0, sp_hwm], - CmmReg spLimReg] + CmmReg $ spLimReg platform] -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr] + hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr platform, hpLimExpr platform] case mb_stk_hwm of Nothing -> return () @@ -634,22 +635,22 @@ -- See Note [Self-recursive loop header]. self_loop_info <- getSelfLoop case self_loop_info of - Just MkSelfLoopInfo { sli_header_block = loop_header_id } + Just (_, loop_header_id, _) | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return () case mb_alloc_lit of Just alloc_lit -> do - let bump_hp = cmmOffsetExprB platform hpExpr alloc_lit - alloc_n = mkAssign hpAllocReg alloc_lit + let bump_hp = cmmOffsetExprB platform (hpExpr platform) alloc_lit + alloc_n = mkAssign (hpAllocReg platform) alloc_lit tickyHeapCheck - emitAssign hpReg bump_hp + emitAssign (hpReg platform) bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) Nothing -> when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) - [CmmReg hpLimReg, + [CmmReg $ hpLimReg platform, CmmLit (zeroCLit platform)] emit =<< mkCmmIfGoto' yielding gc_id (Just False) diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs --- a/compiler/GHC/StgToCmm/InfoTableProv.hs +++ b/compiler/GHC/StgToCmm/InfoTableProv.hs @@ -1,82 +1,205 @@ +{-# LANGUAGE CPP #-} + module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where +import Foreign + +#if defined(HAVE_LIBZSTD) +import Foreign.C.Types +import Foreign.Marshal.Utils (copyBytes) +import qualified Data.ByteString.Internal as BSI +import GHC.IO (unsafePerformIO) +#endif + import GHC.Prelude import GHC.Platform +import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile) import GHC.Unit.Module import GHC.Utils.Outputable -import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile) -import GHC.Data.FastString (unpackFS) +import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..)) +import GHC.Cmm import GHC.Cmm.CLabel -import GHC.Cmm.Expr import GHC.Cmm.Utils + import GHC.StgToCmm.Config -import GHC.StgToCmm.Lit (newByteStringCLit) import GHC.StgToCmm.Monad -import GHC.StgToCmm.Utils import GHC.Data.ShortText (ShortText) import qualified GHC.Data.ShortText as ST -import qualified Data.Map.Strict as M import Control.Monad.Trans.State.Strict + import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map.Strict as M -emitIpeBufferListNode :: Module - -> [InfoProvEnt] - -> FCode () +{- +Note [Compression and Decompression of IPE data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Compiling with `-finfo-table-map` causes build results to include a map from +info tables to source positions called the info table provenance entry (IPE) +map. See Note [Mapping Info Tables to Source Positions]. The IPE information +can grow the size of build results significantly. At the time of writing, a +default build of GHC results in a total of 109M of libHSghc-*.so build results. +A default+ipe build of GHC (see ./hadrian/doc/flavours.md) results in 262M of +libHSghc-*.so build results without compression. + +We reduce the impact of IPE data on the size of build results by compressing +the data before it is emitted using the zstd compression library. See +Note [The Info Table Provenance Entry (IPE) Map] for information on the layout +of IPE data on disk and in the RTS. We cannot simply compress all data held in +the IPE entry buffer, as the pointers to info tables must be converted to +memory addresses during linking. Therefore, we can only compress the strings +table and the IPE entries themselves (which essentially only consist of indices +into the strings table). + +With compression, a default+ipe build of GHC results in a total of 205M of +libHSghc-*.so build results. This is over a 20% reduction from the uncompressed +case. + +Decompression happens lazily, as it only occurs when the IPE map is +constructed (which is also done lazily on first lookup or traversal). During +construction, the 'compressed' field of each IPE buffer list node is examined. +If the field indicates that the data has been compressed, the entry data and +strings table are decompressed before continuing with the normal IPE map +construction. +-} + +emitIpeBufferListNode :: + Module + -> [InfoProvEnt] + -> FCode () emitIpeBufferListNode _ [] = return () emitIpeBufferListNode this_mod ents = do cfg <- getStgToCmmConfig - let ctx = stgToCmmContext cfg + + tables_lbl <- mkStringLitLabel <$> newUnique + strings_lbl <- mkStringLitLabel <$> newUnique + entries_lbl <- mkStringLitLabel <$> newUnique + + let ctx = stgToCmmContext cfg platform = stgToCmmPlatform cfg + int n = mkIntCLit platform n - let (cg_ipes, strtab) = flip runState emptyStringTable $ do - module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod) - mapM (toCgIPE platform ctx module_name) ents + (cg_ipes, strtab) = flip runState emptyStringTable $ do + module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod) + mapM (toCgIPE platform ctx module_name) ents - let -- Emit the fields of an IpeBufferEntry struct. - toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit] - toIpeBufferEntry cg_ipe = - [ CmmLabel (ipeInfoTablePtr cg_ipe) - , strtab_offset (ipeTableName cg_ipe) - , strtab_offset (ipeClosureDesc cg_ipe) - , strtab_offset (ipeTypeDesc cg_ipe) - , strtab_offset (ipeLabel cg_ipe) - , strtab_offset (ipeModuleName cg_ipe) - , strtab_offset (ipeSrcFile cg_ipe) - , strtab_offset (ipeSrcSpan cg_ipe) - , int32 0 - ] + tables :: [CmmStatic] + tables = map (CmmStaticLit . CmmLabel . ipeInfoTablePtr) cg_ipes - int n = mkIntCLit platform n - int32 n = CmmInt n W32 - strtab_offset (StrTabOffset n) = int32 (fromIntegral n) + uncompressed_strings :: BS.ByteString + uncompressed_strings = getStringTableStrings strtab - strings <- newByteStringCLit (getStringTableStrings strtab) - let lits = [ zeroCLit platform -- 'next' field - , strings -- 'strings' field - , int $ length cg_ipes -- 'count' field - ] ++ concatMap toIpeBufferEntry cg_ipes - emitDataLits (mkIPELabel this_mod) lits + strings_bytes :: BS.ByteString + strings_bytes = compress defaultCompressionLevel uncompressed_strings + strings :: [CmmStatic] + strings = [CmmString strings_bytes] + + uncompressed_entries :: BS.ByteString + uncompressed_entries = toIpeBufferEntries (platformByteOrder platform) cg_ipes + + entries_bytes :: BS.ByteString + entries_bytes = compress defaultCompressionLevel uncompressed_entries + + entries :: [CmmStatic] + entries = [CmmString entries_bytes] + + ipe_buffer_lbl :: CLabel + ipe_buffer_lbl = mkIPELabel this_mod + + ipe_buffer_node :: [CmmStatic] + ipe_buffer_node = map CmmStaticLit + [ -- 'next' field + zeroCLit platform + + -- 'compressed' field + , int do_compress + + -- 'count' field + , int $ length cg_ipes + + -- 'tables' field + , CmmLabel tables_lbl + + -- 'entries' field + , CmmLabel entries_lbl + + -- 'entries_size' field (decompressed size) + , int $ BS.length uncompressed_entries + + -- 'string_table' field + , CmmLabel strings_lbl + + -- 'string_table_size' field (decompressed size) + , int $ BS.length uncompressed_strings + ] + + -- Emit the list of info table pointers + emitDecl $ CmmData + (Section Data tables_lbl) + (CmmStaticsRaw tables_lbl tables) + + -- Emit the strings table + emitDecl $ CmmData + (Section Data strings_lbl) + (CmmStaticsRaw strings_lbl strings) + + -- Emit the list of IPE buffer entries + emitDecl $ CmmData + (Section Data entries_lbl) + (CmmStaticsRaw entries_lbl entries) + + -- Emit the IPE buffer list node + emitDecl $ CmmData + (Section Data ipe_buffer_lbl) + (CmmStaticsRaw ipe_buffer_lbl ipe_buffer_node) + +-- | Emit the fields of an IpeBufferEntry struct for each entry in a given list. +toIpeBufferEntries :: + ByteOrder -- ^ Byte order to write the data in + -> [CgInfoProvEnt] -- ^ List of IPE buffer entries + -> BS.ByteString +toIpeBufferEntries byte_order cg_ipes = + BSL.toStrict . BSB.toLazyByteString . mconcat + $ map (mconcat . map word32Builder . to_ipe_buf_ent) cg_ipes + where + to_ipe_buf_ent :: CgInfoProvEnt -> [Word32] + to_ipe_buf_ent cg_ipe = + [ ipeTableName cg_ipe + , ipeClosureDesc cg_ipe + , ipeTypeDesc cg_ipe + , ipeLabel cg_ipe + , ipeModuleName cg_ipe + , ipeSrcFile cg_ipe + , ipeSrcSpan cg_ipe + , 0 -- padding + ] + + word32Builder :: Word32 -> BSB.Builder + word32Builder = case byte_order of + BigEndian -> BSB.word32BE + LittleEndian -> BSB.word32LE + toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt toCgIPE platform ctx module_name ipe = do table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe)) closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe) type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe - let label_str = maybe "" snd (infoTableProv ipe) + let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe) let (src_loc_file, src_loc_span) = case infoTableProv ipe of - Nothing -> ("", "") + Nothing -> (mempty, "") Just (span, _) -> - let file = unpackFS $ srcSpanFile span + let file = fastStringToShortText $ srcSpanFile span coords = renderWithContext ctx (pprUserRealSpan False span) in (file, coords) - label <- lookupStringTable $ ST.pack label_str - src_file <- lookupStringTable $ ST.pack src_loc_file + label <- lookupStringTable $ ST.pack label_str + src_file <- lookupStringTable src_loc_file src_span <- lookupStringTable $ ST.pack src_loc_span return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe , ipeTableName = table_name @@ -104,7 +227,7 @@ , stLookup :: !(M.Map ShortText StrTabOffset) } -newtype StrTabOffset = StrTabOffset Int +type StrTabOffset = Word32 emptyStringTable :: StringTable emptyStringTable = @@ -129,8 +252,49 @@ , stLength = stLength st + ST.byteLength str + 1 , stLookup = M.insert str res (stLookup st) } - res = StrTabOffset (stLength st) + res = fromIntegral (stLength st) in (res, st') + +do_compress :: Int +compress :: Int -> BS.ByteString -> BS.ByteString +#if !defined(HAVE_LIBZSTD) +do_compress = 0 +compress _ bs = bs +#else +do_compress = 1 + +compress clvl (BSI.PS srcForeignPtr off len) = unsafePerformIO $ + withForeignPtr srcForeignPtr $ \srcPtr -> do + maxCompressedSize <- zstd_compress_bound $ fromIntegral len + dstForeignPtr <- BSI.mallocByteString (fromIntegral maxCompressedSize) + withForeignPtr dstForeignPtr $ \dstPtr -> do + compressedSize <- fromIntegral <$> + zstd_compress + dstPtr + maxCompressedSize + (srcPtr `plusPtr` off) + (fromIntegral len) + (fromIntegral clvl) + BSI.create compressedSize $ \p -> copyBytes p dstPtr compressedSize + +foreign import ccall unsafe "ZSTD_compress" + zstd_compress :: + Ptr dst -- ^ Destination buffer + -> CSize -- ^ Capacity of destination buffer + -> Ptr src -- ^ Source buffer + -> CSize -- ^ Size of source buffer + -> CInt -- ^ Compression level + -> IO CSize + +-- | Compute the maximum compressed size for a given source buffer size +foreign import ccall unsafe "ZSTD_compressBound" + zstd_compress_bound :: + CSize -- ^ Size of source buffer + -> IO CSize +#endif + +defaultCompressionLevel :: Int +defaultCompressionLevel = 3 newtype DList a = DList ([a] -> [a]) 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 @@ -155,9 +155,10 @@ adjust_words = vHp -rHp ; new_hp <- getHpRelOffset vHp + ; platform <- getPlatform ; emit (if adjust_words == 0 then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + else mkAssign (hpReg platform) new_hp) -- Generates nothing when vHp==rHp ; tickyAllocHeap False adjust_words -- ...ditto @@ -305,10 +306,11 @@ | otherwise -- Note [over-saturated calls] = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (nonVArgs (slowArgs rest_args do_scc_prof)) + (nonVArgs (slowArgs platform rest_args do_scc_prof)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -375,18 +377,18 @@ -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] -slowArgs [] _ = mempty -slowArgs args sccProfilingEnabled -- careful: reps contains voids (V), but args does not - | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled - | otherwise = this_pat ++ slowArgs rest_args sccProfilingEnabled +slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] +slowArgs _ [] _ = mempty +slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V), but args does not + | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled + | otherwise = this_pat ++ slowArgs platform rest_args sccProfilingEnabled where (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args - save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)] + save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)] save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- @@ -404,7 +406,7 @@ getHpRelOffset virtual_offset = do platform <- getPlatform hp_usg <- getHpUsage - return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset)) + return (cmmRegOffW platform (hpReg platform) (hpRel (realHp hp_usg) virtual_offset)) data FieldOffOrPadding a = FieldOff (NonVoid a) -- Something that needs an offset. @@ -554,7 +556,7 @@ argBits :: Platform -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr argBits _ [] = [] argBits platform (P : args) = False : argBits platform args -argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True) +argBits platform (arg : args) = replicate (argRepSizeW platform arg) True ++ argBits platform args ---------------------- diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs --- a/compiler/GHC/StgToCmm/Lit.hs +++ b/compiler/GHC/StgToCmm/Lit.hs @@ -53,8 +53,7 @@ cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] VoidRep -> panic "cgLit:VoidRep" -- ditto - LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId - UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId + BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do platform <- getPlatform 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 @@ -42,8 +42,6 @@ Sequel(..), ReturnKind(..), withSequel, getSequel, - SelfLoopInfo(..), - setTickyCtrLabel, getTickyCtrLabel, tickScope, getTickScope, @@ -300,7 +298,7 @@ -- else the RTS will deadlock _and_ also experience a severe -- performance degradation , fcs_sequel :: !Sequel -- ^ What to do at end of basic block - , fcs_selfloop :: !(Maybe SelfLoopInfo) -- ^ Which tail calls can be compiled as local jumps? + , fcs_selfloop :: Maybe SelfLoopInfo -- ^ Which tail calls can be compiled as local jumps? -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr , fcs_ticky :: !CLabel -- ^ Destination for ticky counts , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks 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 @@ -255,7 +255,7 @@ emitCCall [(res,NoHint)] (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(baseExpr, AddrHint), (arg,AddrHint)] + [(baseExpr platform, AddrHint), (arg,AddrHint)] SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do -- returns the value of arg in res. We're going to therefore @@ -266,7 +266,7 @@ emitCCall [(tmp2,NoHint)] (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + [(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do @@ -277,10 +277,10 @@ emitAssign (CmmLocal res) val GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) cccsExpr + emitAssign (CmmLocal res) (cccsExpr platform) MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) currentTSOExpr + emitAssign (CmmLocal res) (currentTSOExpr platform) ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire) @@ -297,16 +297,12 @@ -- MutVar's value. emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease) [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ] + emitDirtyMutVar mutv (CmmReg old_val) - platform <- getPlatform - mkdirtyMutVarCCall <- getCode $! emitCCall - [{-no results-}] - (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] - emit =<< mkCmmIfThen - (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) - (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv)) - mkdirtyMutVarCCall + AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do + let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile) + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val] + emitDirtyMutVar mutv (CmmReg (CmmLocal res)) -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -710,14 +706,22 @@ doCopyByteArrayOp src src_off dst dst_off n CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyMutableByteArrayOp src src_off dst dst_off n + CopyMutableByteArrayNonOverlappingOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> + doCopyMutableByteArrayNonOverlappingOp src src_off dst dst_off n CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> doCopyByteArrayToAddrOp src src_off dst n CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> doCopyMutableByteArrayToAddrOp src src_off dst n CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyAddrToByteArrayOp src dst dst_off n + CopyAddrToAddrOp -> \[src,dst,n] -> opIntoRegs $ \[] -> + doCopyAddrToAddrOp src dst n + CopyAddrToAddrNonOverlappingOp -> \[src,dst,n] -> opIntoRegs $ \[] -> + doCopyAddrToAddrNonOverlappingOp src dst n SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> doSetByteArrayOp ba off len c + SetAddrRangeOp -> \[dst,len,c] -> opIntoRegs $ \[] -> + doSetAddrRangeOp dst len c -- Comparing byte arrays CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> @@ -1391,6 +1395,11 @@ DoubleDivOp -> \args -> opTranslate args (MO_F_Quot W64) DoubleNegOp -> \args -> opTranslate args (MO_F_Neg W64) + DoubleFMAdd -> fmaOp FMAdd W64 + DoubleFMSub -> fmaOp FMSub W64 + DoubleFNMAdd -> fmaOp FNMAdd W64 + DoubleFNMSub -> fmaOp FNMSub W64 + -- Float ops FloatEqOp -> \args -> opTranslate args (MO_F_Eq W32) @@ -1406,6 +1415,11 @@ FloatDivOp -> \args -> opTranslate args (MO_F_Quot W32) FloatNegOp -> \args -> opTranslate args (MO_F_Neg W32) + FloatFMAdd -> fmaOp FMAdd W32 + FloatFMSub -> fmaOp FMSub W32 + FloatFNMAdd -> fmaOp FNMAdd W32 + FloatFNMSub -> fmaOp FNMSub W32 + -- Vector ops (VecAddOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Add n w) @@ -1731,6 +1745,27 @@ allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg allowInt2Mul = stgToCmmAllowIntMul2Instr cfg + allowFMA = stgToCmmAllowFMAInstr cfg + + fmaOp :: FMASign -> Width -> [CmmActual] -> PrimopCmmEmit + fmaOp signs w args@[arg_x, arg_y, arg_z] + | allowFMA signs + = opTranslate args (MO_FMA signs w) + | otherwise + = case signs of + + -- For fused multiply-add x * y + z, we fall back to the C implementation. + FMAdd -> opIntoRegs $ \ [res] -> fmaCCall w res arg_x arg_y arg_z + + -- Other fused multiply-add operations are implemented in terms of fmadd + -- This is sound: it does not lose any precision. + FMSub -> fmaOp FMAdd w [arg_x, arg_y, neg arg_z] + FNMAdd -> fmaOp FMAdd w [neg arg_x, arg_y, arg_z] + FNMSub -> fmaOp FMAdd w [neg arg_x, arg_y, neg arg_z] + where + neg x = CmmMachOp (MO_F_Neg w) [x] + fmaOp _ _ _ = panic "fmaOp: wrong number of arguments (expected 3)" + data PrimopCmmEmit -- | Out of line fake primop that's actually just a foreign call to other -- (presumably) C--. @@ -2019,6 +2054,19 @@ ] genericIntMul2Op _ _ = panic "genericIntMul2Op" +fmaCCall :: Width -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> FCode () +fmaCCall width res arg_x arg_y arg_z = + emitCCall + [(res,NoHint)] + (CmmLit (CmmLabel fma_lbl)) + [(arg_x,NoHint), (arg_y,NoHint), (arg_z,NoHint)] + where + fma_lbl = mkForeignLabel fma_op Nothing ForeignLabelInExternalPackage IsFunction + fma_op = case width of + W32 -> fsLit "fmaf" + W64 -> fsLit "fma" + _ -> panic ("fmaCall: " ++ show width) + ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. @@ -2026,8 +2074,8 @@ -> CmmType -- ^ index type -> AlignmentSpec alignmentFromTypes ty idx_ty - | typeWidth ty <= typeWidth idx_ty = NaturallyAligned - | otherwise = Unaligned + | typeWidth ty < typeWidth idx_ty = NaturallyAligned + | otherwise = Unaligned doIndexOffAddrOp :: Maybe MachOp -> CmmType @@ -2465,7 +2513,7 @@ let hdr_size = fixedHdrSize profile - base <- allocHeapClosure rep info_ptr cccsExpr + base <- allocHeapClosure rep info_ptr (cccsExpr platform) [ (mkIntExpr platform n, hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] @@ -2567,6 +2615,19 @@ (getCode $ emitMemcpyCall dst_p src_p bytes align) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. Assumes the two ranges are disjoint +doCopyMutableByteArrayNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayNonOverlappingOp = emitCopyByteArray copy + where + copy _src _dst dst_p src_p bytes align = do + emitCheckedMemcpyCall dst_p src_p bytes align + + emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()) -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr @@ -2620,6 +2681,22 @@ dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) +-- | Takes a source 'Addr#', a destination 'Addr#', and the number of +-- bytes to copy. Copies the given number of bytes from the source +-- memory region to the destination array. +doCopyAddrToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToAddrOp src_p dst_p bytes = do + -- Use memmove; the ranges may overlap + emitMemmoveCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'Addr#', a destination 'Addr#', and the number of +-- bytes to copy. Copies the given number of bytes from the source +-- memory region to the destination region. The regions may not overlap. +doCopyAddrToAddrNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToAddrNonOverlappingOp src_p dst_p bytes = do + -- Use memcpy; the ranges may not overlap + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + ifNonZero :: CmmExpr -> FCode () -> FCode () ifNonZero e it = do platform <- getPlatform @@ -2635,7 +2712,7 @@ -- | Takes a 'MutableByteArray#', an offset into the array, a length, -- and a byte, and sets each of the selected bytes in the array to the --- character. +-- given byte. doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do @@ -2652,6 +2729,14 @@ p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off emitMemsetCall p c len align +-- | Takes an 'Addr#', a length, and a byte, and sets each of the +-- selected bytes in memory to the given byte. +doSetAddrRangeOp :: CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetAddrRangeOp dst len c = do + emitMemsetCall dst c len (mkAlignment 1) + + -- ---------------------------------------------------------------------------- -- Allocating arrays @@ -2673,7 +2758,7 @@ (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - base <- allocHeapClosure rep info_ptr cccsExpr payload + base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base @@ -2868,7 +2953,7 @@ let hdr_size = fixedHdrSize profile constants = platformConstants platform - base <- allocHeapClosure rep info_ptr cccsExpr + base <- allocHeapClosure rep info_ptr (cccsExpr platform) [ (mkIntExpr platform n, hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) , (mkIntExpr platform (nonHdrSizeW rep), @@ -2908,7 +2993,7 @@ let hdr_size = fixedHdrSize profile - base <- allocHeapClosure rep info_ptr cccsExpr + base <- allocHeapClosure rep info_ptr (cccsExpr platform) [ (mkIntExpr platform n, hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] @@ -3301,6 +3386,21 @@ if elem_w == idx_w then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) + +-- | Write barrier for @MUT_VAR@ modification. +emitDirtyMutVar :: CmmExpr -> CmmExpr -> FCode () +emitDirtyMutVar mutvar old_val = do + cfg <- getStgToCmmConfig + platform <- getPlatform + mkdirtyMutVarCCall <- getCode $! emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(baseExpr platform, AddrHint), (mutvar, AddrHint), (old_val, AddrHint)] + + emit =<< mkCmmIfThen + (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) + (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutvar)) + mkdirtyMutVarCCall --------------------------------------------------------------------------- -- Pushing to the update remembered set diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -71,8 +71,8 @@ ccType :: Platform -> CmmType -- Type of a cost centre ccType = bWord -storeCurCCS :: CmmExpr -> CmmAGraph -storeCurCCS = mkAssign cccsReg +storeCurCCS :: Platform -> CmmExpr -> CmmAGraph +storeCurCCS platform = mkAssign (cccsReg platform) mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -103,7 +103,7 @@ initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS do platform <- getPlatform - emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr + emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (cccsExpr platform) -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -144,14 +144,14 @@ if not sccProfilingEnabled then return Nothing else do local_cc <- newTemp (ccType platform) - emitAssign (CmmLocal local_cc) cccsExpr + emitAssign (CmmLocal local_cc) (cccsExpr platform) return (Just local_cc) -restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre :: Platform -> Maybe LocalReg -> FCode () +restoreCurrentCostCentre _ Nothing = return () -restoreCurrentCostCentre (Just local_cc) - = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) +restoreCurrentCostCentre platform (Just local_cc) + = emit (storeCurCCS platform (CmmReg (CmmLocal local_cc))) ------------------------------------------------------------------------------- @@ -191,7 +191,7 @@ enterCostCentreThunk closure = ifProfiling $ do platform <- getPlatform - emit $ storeCurCCS (costCentreFrom platform closure) + emit $ storeCurCCS platform (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ @@ -200,7 +200,7 @@ emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)] + [(baseExpr platform, AddrHint), (costCentreFrom platform closure, AddrHint)] False -- otherwise we have a top-level function, nothing to do @@ -274,27 +274,24 @@ where (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform --- | Emit info-table provenance declarations and track IPE stats. --- --- Note that the stats passed to this function will (rather, should) only ever --- contain stats for skipped STACK info tables accumulated in --- 'generateCgIPEStub'. -initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> FCode (Maybe (IPEStats, CStub)) -initInfoTableProv stats infos itmap +-- | Emit info-table provenance declarations +initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub +initInfoTableProv infos itmap = do cfg <- getStgToCmmConfig - let (stats', ents) = convertInfoProvMap cfg this_mod itmap stats infos - info_table = stgToCmmInfoTableMap cfg - platform = stgToCmmPlatform cfg - this_mod = stgToCmmThisModule cfg + let ents = convertInfoProvMap infos this_mod itmap + info_table = stgToCmmInfoTableMap cfg + platform = stgToCmmPlatform cfg + this_mod = stgToCmmThisModule cfg + case ents of - [] -> return Nothing + [] -> return mempty _ -> do -- Emit IPE buffer emitIpeBufferListNode this_mod ents -- Create the C stub which initialises the IPE map - return (Just (stats', ipInitCode info_table platform this_mod)) + return (ipInitCode info_table platform this_mod) -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -303,9 +300,9 @@ emitSetCCC cc tick push = ifProfiling $ do platform <- getPlatform tmp <- newTemp (ccsType platform) - pushCostCentre tmp cccsExpr cc + pushCostCentre tmp (cccsExpr platform) cc when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS platform (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs --- a/compiler/GHC/StgToCmm/Sequel.hs +++ b/compiler/GHC/StgToCmm/Sequel.hs @@ -12,14 +12,13 @@ module GHC.StgToCmm.Sequel ( Sequel(..) - , SelfLoopInfo(..) + , SelfLoopInfo ) where import GHC.Cmm.BlockId import GHC.Cmm import GHC.Types.Id -import GHC.Types.Basic (RepArity) import GHC.Utils.Outputable import GHC.Prelude @@ -42,14 +41,5 @@ ppr Return = text "Return" ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b -data SelfLoopInfo = MkSelfLoopInfo - { sli_id :: !Id - , sli_arity :: !RepArity - -- ^ always equal to 'idFunRepArity' of sli_id, - -- i.e. unarised arity, including void arguments - , sli_registers :: ![LocalReg] - -- ^ Excludes void arguments (LocalReg is never void) - , sli_header_block :: !BlockId - } - +type SelfLoopInfo = (Id, BlockId, [LocalReg]) -------------------------------------------------------------------------------- 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 @@ -157,7 +157,6 @@ import GHC.StgToCmm.Env (getCgInfo_maybe) import Data.Coerce (coerce) import GHC.Utils.Json -import GHC.Utils.Unique (anyOfUnique) ----------------------------------------------------------------------------- -- @@ -885,19 +884,20 @@ | otherwise = case tcSplitTyConApp_maybe ty of Nothing -> '.' Just (tycon, _) -> + let anyOf us = getUnique tycon `elem` us in case () of - _ | anyOfUnique tycon [fUNTyConKey] -> '>' - | anyOfUnique tycon [charTyConKey] -> 'C' - | anyOfUnique tycon [charPrimTyConKey] -> 'c' - | anyOfUnique tycon [doubleTyConKey] -> 'D' - | anyOfUnique tycon [doublePrimTyConKey] -> 'd' - | anyOfUnique tycon [floatTyConKey] -> 'F' - | anyOfUnique tycon [floatPrimTyConKey] -> 'f' - | anyOfUnique tycon [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I' - | anyOfUnique tycon [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i' - | anyOfUnique tycon [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W' - | anyOfUnique tycon [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' - | anyOfUnique tycon [listTyConKey] -> 'L' + _ | anyOf [fUNTyConKey] -> '>' + | anyOf [charTyConKey] -> 'C' + | anyOf [charPrimTyConKey] -> 'c' + | anyOf [doubleTyConKey] -> 'D' + | anyOf [doublePrimTyConKey] -> 'd' + | anyOf [floatTyConKey] -> 'F' + | anyOf [floatPrimTyConKey] -> 'f' + | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I' + | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i' + | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W' + | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' + | anyOf [listTyConKey] -> 'L' | isUnboxedTupleTyCon tycon -> 't' | isTupleTyCon tycon -> 'T' | isPrimTyCon tycon -> 'P' 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 @@ -7,8 +7,6 @@ -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} module GHC.StgToCmm.Utils ( emitDataLits, emitRODataLits, @@ -45,8 +43,7 @@ emitUpdRemSetPush, emitUpdRemSetPushThunk, - convertInfoProvMap, cmmInfoTableToInfoProvEnt, IPEStats(..), - closureIpeStats, fallbackIpeStats, skippedIpeStats, + convertInfoProvMap, cmmInfoTableToInfoProvEnt ) where import GHC.Prelude hiding ( head, init, last, tail ) @@ -93,8 +90,6 @@ import GHC.Data.Maybe import Control.Monad import qualified Data.Map.Strict as Map -import qualified Data.IntMap.Strict as I -import qualified Data.Semigroup (Semigroup(..)) -------------------------------------------------------------------------- -- @@ -245,15 +240,17 @@ callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerSaveGlobalReg platform reg - = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) + = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal (GlobalRegUse reg spill_ty))) + where + spill_ty = globalRegSpillType platform reg callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerRestoreGlobalReg platform reg - = mkAssign (CmmGlobal reg) + = mkAssign (CmmGlobal (GlobalRegUse reg spill_ty)) (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType platform reg) - NaturallyAligned) - + spill_ty NaturallyAligned) + where + spill_ty = globalRegSpillType platform reg ------------------------------------------------------------------------- -- @@ -583,21 +580,23 @@ -- remembered set. emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten -> FCode () -emitUpdRemSetPush ptr = +emitUpdRemSetPush ptr = do + platform <- getPlatform emitRtsCall rtsUnitId (fsLit "updateRemembSetPushClosure_") - [(CmmReg (CmmGlobal BaseReg), AddrHint), + [(CmmReg $ baseReg platform, AddrHint), (ptr, AddrHint)] False emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk -> FCode () -emitUpdRemSetPushThunk ptr = +emitUpdRemSetPushThunk ptr = do + platform <- getPlatform emitRtsCall rtsUnitId (fsLit "updateRemembSetPushThunk_") - [(CmmReg (CmmGlobal BaseReg), AddrHint), + [(CmmReg $ baseReg platform, AddrHint), (ptr, AddrHint)] False @@ -608,96 +607,39 @@ cn = rtsClosureType (cit_rep cmit) in InfoProvEnt cl cn "" this_mod Nothing -data IPEStats = IPEStats { ipe_total :: !Int - , ipe_closure_types :: !(I.IntMap Int) - , ipe_fallback :: !Int - , ipe_skipped :: !Int } - -instance Semigroup IPEStats where - (IPEStats a1 a2 a3 a4) <> (IPEStats b1 b2 b3 b4) = IPEStats (a1 + b1) (I.unionWith (+) a2 b2) (a3 + b3) (a4 + b4) - -instance Monoid IPEStats where - mempty = IPEStats 0 I.empty 0 0 - -fallbackIpeStats :: IPEStats -fallbackIpeStats = mempty { ipe_total = 1, ipe_fallback = 1 } - -closureIpeStats :: Int -> IPEStats -closureIpeStats t = mempty { ipe_total = 1, ipe_closure_types = I.singleton t 1 } - -skippedIpeStats :: IPEStats -skippedIpeStats = mempty { ipe_skipped = 1 } - -instance Outputable IPEStats where - ppr = pprIPEStats - -pprIPEStats :: IPEStats -> SDoc -pprIPEStats (IPEStats{..}) = - vcat $ [ text "Tables with info:" <+> ppr ipe_total - , text "Tables with fallback:" <+> ppr ipe_fallback - , text "Tables skipped:" <+> ppr ipe_skipped - ] ++ [ text "Info(" <> ppr k <> text "):" <+> ppr n | (k, n) <- I.assocs ipe_closure_types ] - -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenance table. --- --- The initial stats given to this function will (or should) only contain stats --- for stack info tables skipped during 'generateCgIPEStub'. As the fold --- progresses, counts of tables per closure type will be accumulated. -convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt]) -convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) initStats cmits = - foldl' convertInfoProvMap' (initStats, []) cmits - where - convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt]) - convertInfoProvMap' (!stats, acc) cmit = do - let - cl = cit_lbl cmit +convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] +convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = + map (\cmit -> + let cl = cit_lbl cmit cn = rtsClosureType (cit_rep cmit) tyString :: Outputable a => a -> String tyString = renderWithContext defaultSDocContext . ppr - lookupClosureMap :: Maybe (IPEStats, InfoProvEnt) + lookupClosureMap :: Maybe InfoProvEnt lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of - Just (ty, mbspan) -> Just (closureIpeStats cn, (InfoProvEnt cl cn (tyString ty) this_mod mbspan)) + Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan) Nothing -> Nothing - lookupDataConMap :: Maybe (IPEStats, InfoProvEnt) - lookupDataConMap = (closureIpeStats cn,) <$> do + lookupDataConMap = do UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique -- Lookup is linear but lists will be small (< 100) - return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))) + return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) - lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt) lookupInfoTableToSourceLocation = do sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap - return $ (closureIpeStats cn, (InfoProvEnt cl cn "" this_mod sourceNote)) + return $ InfoProvEnt cl cn "" this_mod sourceNote -- This catches things like prim closure types and anything else which doesn't have a -- source location - simpleFallback = - if stgToCmmInfoTableMapWithFallback cfg then - -- Create a default entry with fallback IPE data - Just (fallbackIpeStats, cmmInfoTableToInfoProvEnt this_mod cmit) - else - -- If we are omitting tables with fallback info - -- (-fno-info-table-map-with-fallback was given), do not create an - -- entry - Nothing - - trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt]) - trackSkipped Nothing = - (stats Data.Semigroup.<> skippedIpeStats, acc) - trackSkipped (Just (s, !c)) = - (stats Data.Semigroup.<> s, c:acc) + simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit - trackSkipped $ - if (isStackRep . cit_rep) cmit then - -- Note that we should have already skipped STACK info tables if - -- necessary in 'generateCgIPEStub', so we should not need to worry - -- about doing that here. - fromMaybe simpleFallback (Just <$> lookupInfoTableToSourceLocation) - else - fromMaybe simpleFallback (Just <$> firstJust lookupDataConMap lookupClosureMap) + in + if (isStackRep . cit_rep) cmit then + fromMaybe simpleFallback lookupInfoTableToSourceLocation + else + fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs --- a/compiler/GHC/StgToJS/Apply.hs +++ b/compiler/GHC/StgToJS/Apply.hs @@ -27,7 +27,7 @@ import GHC.Prelude hiding ((.|.)) -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Arg @@ -39,7 +39,6 @@ import GHC.StgToJS.Types import GHC.StgToJS.Profiling import GHC.StgToJS.Regs -import GHC.StgToJS.CoreUtils import GHC.StgToJS.Utils import GHC.StgToJS.Rts.Types import GHC.StgToJS.Stack @@ -49,6 +48,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre +import GHC.Types.RepType (mightBeFunTy) import GHC.Stg.Syntax @@ -110,7 +110,7 @@ prof <- csProf <$> getSettings let profArg = if prof then [jCafCCS] else [] a <- genArg x - return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg) + return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) , ExprInline Nothing ) @@ -205,7 +205,7 @@ -- no args and Id can't be a function: just enter it | [] <- args , idFunRepArity i == 0 - , not (might_be_a_function (idType i)) + , not (mightBeFunTy (idType i)) = do enter_id <- genIdArg i >>= \case @@ -408,17 +408,11 @@ [ TxtI "h$apply" ||= toJExpr (JList []) , TxtI "h$paps" ||= toJExpr (JList []) , ApplStat (var "h$initStatic" .^ "push") - [ ValExpr $ JFunc [] $ jVar \i -> mconcat - [ i |= zero_ - , WhileStat False (i .<. Int 65536) $ mconcat - [ var "h$apply" .! i |= var "h$ap_gen" - , preIncrS i - ] - , i |= zero_ - , WhileStat False (i .<. Int 128) $ mconcat - [ var "h$paps" .! i |= var "h$pap_gen" - , preIncrS i - ] + [ ValExpr $ JFunc [] $ mconcat + [ jFor (|= zero_) (.<. Int 65536) preIncrS + (\j -> var "h$apply" .! j |= var "h$ap_gen") + , jFor (|= zero_) (.<. Int 128) preIncrS + (\j -> var "h$paps" .! j |= var "h$pap_gen") , mconcat (map assignSpec applySpec) , mconcat (map assignPap specPap) ] @@ -596,7 +590,7 @@ -- genericFastApply :: StgToJSConfig -> JStat genericFastApply s = - TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c -> + jFun (TxtI "h$ap_gen_fast") \tag -> jVar \c -> [traceRts s (jString "h$ap_gen_fast: " + tag) , c |= closureEntry r1 , SwitchStat (entryClosureType c) @@ -808,12 +802,12 @@ -- h$ap_n_r_fast is entered if a function of unknown arity is called, n -- arguments are already in r registers fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat -fastApply s fun_name nargs nvars = func ||= body0 +fastApply s fun_name nargs nvars = body0 where -- special case for h$ap_0_0_fast body0 = if nargs == 0 && nvars == 0 - then jLam (enter s r1) - else toJExpr (JFunc myFunArgs body) + then jFun func (enter s r1) + else FuncStat func myFunArgs body func = TxtI fun_name @@ -881,7 +875,7 @@ zeroApply :: StgToJSConfig -> JStat zeroApply s = mconcat - [ TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c) + [ jFun (TxtI "h$e") (\c -> (r1 |= c) <> enter s c) ] -- carefully enter a closure that might be a thunk or a function @@ -979,13 +973,13 @@ mkSel :: FastString -> (JExpr -> JExpr) -> JStat mkSel name sel = mconcat - [TxtI createName ||= jLam \r -> mconcat + [jFun (TxtI createName) \r -> mconcat [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc")) , ifS (isThunk r .||. isBlackhole r) (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)])) (returnS (sel r)) ] - , TxtI resName ||= jLam \r -> mconcat + , jFun (TxtI resName) \r -> mconcat [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc")) , returnS (sel r) ] @@ -1112,7 +1106,7 @@ -- general utilities -- move the first n registers, starting at R2, m places up (do not use with negative m) moveRegs2 :: JStat -moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch +moveRegs2 = jFun (TxtI "h$moveRegs2") moveSwitch where moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m) -- fast cases diff --git a/compiler/GHC/StgToJS/Arg.hs b/compiler/GHC/StgToJS/Arg.hs --- a/compiler/GHC/StgToJS/Arg.hs +++ b/compiler/GHC/StgToJS/Arg.hs @@ -30,14 +30,14 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.DataCon import GHC.StgToJS.Types import GHC.StgToJS.Monad import GHC.StgToJS.Literal -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Profiling import GHC.StgToJS.Ids diff --git a/compiler/GHC/StgToJS/Closure.hs b/compiler/GHC/StgToJS/Closure.hs --- a/compiler/GHC/StgToJS/Closure.hs +++ b/compiler/GHC/StgToJS/Closure.hs @@ -10,6 +10,15 @@ , assignClosure , CopyCC (..) , copyClosure + , mkClosure + -- $names + , allocData + , allocClsA + , dataName + , clsName + , dataFieldName + , varName + , jsClosureCount ) where @@ -18,12 +27,15 @@ import GHC.StgToJS.Heap import GHC.StgToJS.Types -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Regs (stack,sp) import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.Types.Unique.Map + +import Data.Array import Data.Monoid import qualified Data.Bits as Bits @@ -104,7 +116,7 @@ closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@ -> JStat -- ^ rhs -> JStat -closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci +closure ci body = (jFun (ciVar ci) body) `mappend` closureInfoStat False ci conClosure :: Ident -> FastString -> CILayout -> Int -> JStat conClosure symbol name layout constr = @@ -154,3 +166,78 @@ ] <> case copy_cc of DontCopyCC -> mempty CopyCC -> closureCC t |= closureCC s + +mkClosure :: JExpr -> [JExpr] -> JExpr -> Maybe JExpr -> Closure +mkClosure entry fields meta cc = Closure + { clEntry = entry + , clField1 = x1 + , clField2 = x2 + , clMeta = meta + , clCC = cc + } + where + x1 = case fields of + [] -> null_ + x:_ -> x + x2 = case fields of + [] -> null_ + [_] -> null_ + [_,x] -> x + _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (map dataFieldName [1..]) (x:xs) + + +------------------------------------------------------------------------------- +-- Name Caches +------------------------------------------------------------------------------- +-- $names + +-- | Cache "dXXX" field names +dataFieldCache :: Array Int FastString +dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) + +-- | Data names are used in the AST, and logging has determined that 255 is the maximum number we see. +nFieldCache :: Int +nFieldCache = 255 + +-- | We use this in the RTS to determine the number of generated closures. These closures use the names +-- cached here, so we bind them to the same number. +jsClosureCount :: Int +jsClosureCount = 24 + +dataFieldName :: Int -> FastString +dataFieldName i + | i < 0 || i > nFieldCache = mkFastString ('d' : show i) + | otherwise = dataFieldCache ! i + +-- | Cache "h$dXXX" names +dataCache :: Array Int FastString +dataCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount]) + +dataName :: Int -> FastString +dataName i + | i < 0 || i > nFieldCache = mkFastString ("h$d" ++ show i) + | otherwise = dataCache ! i + +allocData :: Int -> JExpr +allocData i = toJExpr (TxtI (dataName i)) + +-- | Cache "h$cXXX" names +clsCache :: Array Int FastString +clsCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount]) + +clsName :: Int -> FastString +clsName i + | i < 0 || i > jsClosureCount = mkFastString ("h$c" ++ show i) + | otherwise = clsCache ! i + +allocClsA :: Int -> JExpr +allocClsA i = toJExpr (TxtI (clsName i)) + +-- | Cache "xXXX" names +varCache :: Array Int Ident +varCache = listArray (0,jsClosureCount) (map (TxtI . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount]) + +varName :: Int -> Ident +varName i + | i < 0 || i > jsClosureCount = TxtI $ mkFastString ('x' : show i) + | otherwise = varCache ! i diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs --- a/compiler/GHC/StgToJS/CodeGen.hs +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -13,16 +13,16 @@ import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) import GHC.JS.Ppr -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Arg import GHC.StgToJS.Sinker import GHC.StgToJS.Types import qualified GHC.StgToJS.Object as Object -import GHC.StgToJS.StgUtils -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Deps import GHC.StgToJS.Expr import GHC.StgToJS.ExprCtx @@ -90,11 +90,11 @@ -- Doc to dump when -ddump-js is enabled when (logHasDumpFlag logger Opt_D_dump_js) $ do putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS - $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus) + $ vcat (fmap (jsToDoc . oiStat . luObjBlock) lus) -- Write the object file bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB - Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus) + Object.putObject bh (moduleName this_mod) deps (map luObjBlock lus) createDirectoryIfMissing True (takeDirectory output_fn) writeBinMem bh output_fn @@ -133,11 +133,11 @@ glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( -- O.optimize . - jsSaturate (Just $ modulePrefix m 1) + let stat = ( jsOptimize . + satJStat (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] - let oi = ObjUnit + let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = [] @@ -147,7 +147,7 @@ , oiFImports = [] } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = [] , luOtherExports = syms , luIdDeps = [] @@ -169,7 +169,7 @@ let syms = [moduleExportsSymbol m] let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c - let oi = ObjUnit + let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = [] @@ -179,7 +179,7 @@ , oiFImports = [] } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = [] , luOtherExports = syms , luIdDeps = [] @@ -207,10 +207,11 @@ _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = jsSaturate (Just $ modulePrefix m n) body + let stat = jsOptimize + $ satJStat (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd - let oi = ObjUnit + let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = si @@ -220,7 +221,7 @@ , oiFImports = [] } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = ids , luOtherExports = [] , luIdDeps = [] @@ -244,11 +245,11 @@ let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = -- Opt.optimize . - jsSaturate (Just $ modulePrefix m n) - $ mconcat (reverse extraTl) <> tl + stat = jsOptimize + . satJStat (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps - let oi = ObjUnit + let oi = ObjBlock { oiSymbols = syms , oiClInfo = ci , oiStatic = si @@ -258,7 +259,7 @@ , oiFImports = fRefs } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = topDeps , luOtherExports = [] , luIdDeps = allDeps @@ -288,10 +289,10 @@ genToplevelConEntry :: Id -> CgStgRhs -> G JStat genToplevelConEntry i rhs = case rhs of - StgRhsCon _cc con _mu _ts _args + StgRhsCon _cc con _mu _ts _args _typ | isDataConWorkId i -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT - StgRhsClosure _ _cc _upd_flag _args _body + StgRhsClosure _ _cc _upd_flag _args _body _typ | Just dc <- isDataConWorkId_maybe i -> genSetConInfo i dc (stgRhsLive rhs) -- srt _ -> pure mempty @@ -306,24 +307,24 @@ (fixedLayout $ map uTypeVt fields) (CICon $ dataConTag d) sr - return (ei ||= mkDataEntry) + return (mkDataEntry ei) where -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) (dataConRepArgTys d) -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) -mkDataEntry :: JExpr -mkDataEntry = ValExpr $ JFunc [] returnStack +mkDataEntry :: Ident -> JStat +mkDataEntry i = FuncStat i [] returnStack genToplevelRhs :: Id -> CgStgRhs -> G JStat -- general cases: genToplevelRhs i rhs = case rhs of - StgRhsCon cc con _mu _tys args -> do + StgRhsCon cc con _mu _tys args _typ -> do ii <- identForId i allocConStatic ii cc con args return mempty - StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + StgRhsClosure _ext cc _upd_flag {- srt -} args body typ -> do {- algorithm: - collect all Id refs that are in the global id cache @@ -333,8 +334,8 @@ -} eid@(TxtI eidt) <- identForEntryId i (TxtI idt) <- identForId i - body <- genBody (initExprCtx i) i R2 args body - global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) + body <- genBody (initExprCtx i) R2 args body typ + global_occs <- globalOccs (satJStat (Just "ghcjs_tmp_sat_") body) let lidents = map global_ident global_occs let lids = map global_id global_occs let lidents' = map identFS lidents @@ -364,4 +365,4 @@ sr) ccId <- costCentreStackLbl cc emitStatic idt static ccId - return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body))) + return $ (FuncStat eid [] (ll <> upd <> setcc <> body)) diff --git a/compiler/GHC/StgToJS/CoreUtils.hs b/compiler/GHC/StgToJS/CoreUtils.hs deleted file mode 100644 --- a/compiler/GHC/StgToJS/CoreUtils.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Core utils -module GHC.StgToJS.CoreUtils where - -import GHC.Prelude - -import GHC.JS.Syntax - -import GHC.StgToJS.Types - -import GHC.Stg.Syntax - -import GHC.Tc.Utils.TcType - -import GHC.Builtin.Types -import GHC.Builtin.Types.Prim - -import GHC.Core.DataCon -import GHC.Core.TyCo.Rep -import GHC.Core.TyCon -import GHC.Core.Type - -import GHC.Types.RepType -import GHC.Types.Var -import GHC.Types.Id - -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import qualified Data.Bits as Bits - --- | can we unbox C x to x, only if x is represented as a Number -isUnboxableCon :: DataCon -> Bool -isUnboxableCon dc - | [t] <- dataConRepArgTys dc - , [t1] <- typeVt (scaledThing t) - = isUnboxable t1 && - dataConTag dc == 1 && - length (tyConDataCons $ dataConTyCon dc) == 1 - | otherwise = False - --- | one-constructor types with one primitive field represented as a JS Number --- can be unboxed -isUnboxable :: VarType -> Bool -isUnboxable DoubleV = True -isUnboxable IntV = True -- includes Char# -isUnboxable _ = False - --- | Number of slots occupied by a PrimRep -data SlotCount - = NoSlot - | OneSlot - | TwoSlots - deriving (Show,Eq,Ord) - -instance Outputable SlotCount where - ppr = text . show - --- | Return SlotCount as an Int -slotCount :: SlotCount -> Int -slotCount = \case - NoSlot -> 0 - OneSlot -> 1 - TwoSlots -> 2 - - --- | Number of slots occupied by a value with the given VarType -varSize :: VarType -> Int -varSize = slotCount . varSlotCount - -varSlotCount :: VarType -> SlotCount -varSlotCount VoidV = NoSlot -varSlotCount LongV = TwoSlots -- hi, low -varSlotCount AddrV = TwoSlots -- obj/array, offset -varSlotCount _ = OneSlot - -typeSize :: Type -> Int -typeSize t = sum . map varSize . typeVt $ t - -isVoid :: VarType -> Bool -isVoid VoidV = True -isVoid _ = False - -isPtr :: VarType -> Bool -isPtr PtrV = True -isPtr _ = False - -isSingleVar :: VarType -> Bool -isSingleVar v = varSlotCount v == OneSlot - -isMultiVar :: VarType -> Bool -isMultiVar v = case varSlotCount v of - NoSlot -> False - OneSlot -> False - TwoSlots -> True - --- | can we pattern match on these values in a case? -isMatchable :: [VarType] -> Bool -isMatchable [DoubleV] = True -isMatchable [IntV] = True -isMatchable _ = False - -tyConVt :: HasDebugCallStack => TyCon -> [VarType] -tyConVt = typeVt . mkTyConTy - -idVt :: HasDebugCallStack => Id -> [VarType] -idVt = typeVt . idType - -typeVt :: HasDebugCallStack => Type -> [VarType] -typeVt t | isRuntimeRepKindedTy t = [] -typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t) - --- only use if you know it's not an unboxed tuple -uTypeVt :: HasDebugCallStack => UnaryType -> VarType -uTypeVt ut - | isRuntimeRepKindedTy ut = VoidV --- | isRuntimeRepTy ut = VoidV - -- GHC panics on this otherwise - | Just (tc, ty_args) <- splitTyConApp_maybe ut - , length ty_args /= tyConArity tc = PtrV - | isPrimitiveType ut = (primTypeVt ut) - | otherwise = - case typePrimRep' ut of - [] -> VoidV - [pt] -> primRepVt pt - _ -> pprPanic "uTypeVt: not unary" (ppr ut) - -primRepVt :: HasDebugCallStack => PrimRep -> VarType -primRepVt VoidRep = VoidV -primRepVt LiftedRep = PtrV -- fixme does ByteArray# ever map to this? -primRepVt UnliftedRep = RtsObjV -primRepVt IntRep = IntV -primRepVt Int8Rep = IntV -primRepVt Int16Rep = IntV -primRepVt Int32Rep = IntV -primRepVt WordRep = IntV -primRepVt Word8Rep = IntV -primRepVt Word16Rep = IntV -primRepVt Word32Rep = IntV -primRepVt Int64Rep = LongV -primRepVt Word64Rep = LongV -primRepVt AddrRep = AddrV -primRepVt FloatRep = DoubleV -primRepVt DoubleRep = DoubleV -primRepVt (VecRep{}) = error "uTypeVt: vector types are unsupported" - -typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep] -typePrimRep' ty = kindPrimRep' empty (typeKind ty) - --- | Find the primitive representation of a 'TyCon'. Defined here to --- avoid module loops. Call this only on unlifted tycons. -tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep] -tyConPrimRep' tc = kindPrimRep' empty res_kind - where - res_kind = tyConResKind tc - --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's --- of values of types of this kind. -kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] -kindPrimRep' doc ki - | Just ki' <- coreView ki - = kindPrimRep' doc ki' -kindPrimRep' doc (TyConApp _typ [runtime_rep]) - = -- ASSERT( typ `hasKey` tYPETyConKey ) - runtimeRepPrimRep doc runtime_rep -kindPrimRep' doc ki - = pprPanic "kindPrimRep'" (ppr ki $$ doc) - -primTypeVt :: HasDebugCallStack => Type -> VarType -primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of - Nothing -> error "primTypeVt: not a TyCon" - Just tc - | tc == charPrimTyCon -> IntV - | tc == intPrimTyCon -> IntV - | tc == wordPrimTyCon -> IntV - | tc == floatPrimTyCon -> DoubleV - | tc == doublePrimTyCon -> DoubleV - | tc == int8PrimTyCon -> IntV - | tc == word8PrimTyCon -> IntV - | tc == int16PrimTyCon -> IntV - | tc == word16PrimTyCon -> IntV - | tc == int32PrimTyCon -> IntV - | tc == word32PrimTyCon -> IntV - | tc == int64PrimTyCon -> LongV - | tc == word64PrimTyCon -> LongV - | tc == addrPrimTyCon -> AddrV - | tc == stablePtrPrimTyCon -> AddrV - | tc == stableNamePrimTyCon -> RtsObjV - | tc == statePrimTyCon -> VoidV - | tc == proxyPrimTyCon -> VoidV - | tc == realWorldTyCon -> VoidV - | tc == threadIdPrimTyCon -> RtsObjV - | tc == weakPrimTyCon -> RtsObjV - | tc == arrayPrimTyCon -> ArrV - | tc == smallArrayPrimTyCon -> ArrV - | tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal - | tc == mutableArrayPrimTyCon -> ArrV - | tc == smallMutableArrayPrimTyCon -> ArrV - | tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal - | tc == mutVarPrimTyCon -> RtsObjV - | tc == mVarPrimTyCon -> RtsObjV - | tc == tVarPrimTyCon -> RtsObjV - | tc == bcoPrimTyCon -> RtsObjV -- unsupported? - | tc == stackSnapshotPrimTyCon -> RtsObjV - | tc == ioPortPrimTyCon -> RtsObjV -- unsupported? - | tc == anyTyCon -> PtrV - | tc == compactPrimTyCon -> ObjV -- unsupported? - | tc == eqPrimTyCon -> VoidV -- coercion token? - | tc == eqReprPrimTyCon -> VoidV -- role - | tc == unboxedUnitTyCon -> VoidV -- Void# - | otherwise -> PtrV -- anything else must be some boxed thing - -argVt :: StgArg -> VarType -argVt a = uTypeVt . stgArgType $ a - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - -isBoolDataCon :: DataCon -> Bool -isBoolDataCon dc = isBoolTy (dataConType dc) - --- standard fixed layout: payload types --- payload starts at .d1 for heap objects, entry closest to Sp for stack frames -fixedLayout :: [VarType] -> CILayout -fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts - --- 2-var values might have been moved around separately, use DoubleV as substitute --- ObjV is 1 var, so this is no problem for implicit metadata -stackSlotType :: Id -> VarType -stackSlotType i - | OneSlot <- varSlotCount otype = otype - | otherwise = DoubleV - where otype = uTypeVt (idType i) - -idPrimReps :: Id -> [PrimRep] -idPrimReps = typePrimReps . idType - -typePrimReps :: Type -> [PrimRep] -typePrimReps = typePrimRep . unwrapType - -primRepSize :: PrimRep -> SlotCount -primRepSize p = varSlotCount (primRepVt p) - --- | Associate the given values to each RrimRep in the given order, taking into --- account the number of slots per PrimRep -assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])] -assocPrimReps [] _ = [] -assocPrimReps (r:rs) vs = case (primRepSize r,vs) of - (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs - (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs - (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs - err -> pprPanic "assocPrimReps" (ppr err) - --- | Associate the given values to the Id's PrimReps, taking into account the --- number of slots per PrimRep -assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] -assocIdPrimReps i = assocPrimReps (idPrimReps i) - --- | Associate the given JExpr to the Id's PrimReps, taking into account the --- number of slots per PrimRep -assocIdExprs :: Id -> [JExpr] -> [TypedExpr] -assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) - --- | Return False only if we are *sure* it's a data type --- Look through newtypes etc as much as possible -might_be_a_function :: HasDebugCallStack => Type -> Bool -might_be_a_function ty - | [LiftedRep] <- typePrimRep ty - , Just tc <- tyConAppTyCon_maybe (unwrapType ty) - , isDataTyCon tc - = False - | otherwise - = True - -mkArityTag :: Int -> Int -> Int -mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) - -toTypeList :: [VarType] -> [Int] -toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs --- a/compiler/GHC/StgToJS/DataCon.hs +++ b/compiler/GHC/StgToJS/DataCon.hs @@ -27,14 +27,14 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.JS.Transform import GHC.JS.Make import GHC.StgToJS.Closure import GHC.StgToJS.ExprCtx import GHC.StgToJS.Types import GHC.StgToJS.Monad -import GHC.StgToJS.CoreUtils import GHC.StgToJS.Profiling import GHC.StgToJS.Utils import GHC.StgToJS.Ids @@ -42,11 +42,9 @@ import GHC.Core.DataCon import GHC.Types.CostCentre -import GHC.Types.Unique.Map import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString import Data.Maybe @@ -60,7 +58,10 @@ = allocCon ctxi con currentCCS args | xs <- concatMap typex_expr (ctxTarget ctx) - = pprPanic "genCon: unhandled DataCon" (ppr (con, args, xs)) + = pprPanic "genCon: unhandled DataCon" (ppr (con + , satJExpr Nothing <$> args + , satJExpr Nothing <$> xs + )) -- | Allocate a data constructor. Allocate in this context means bind the data -- constructor to 'to' @@ -88,7 +89,7 @@ | isBoolDataCon con && dataConTag con == 2 -> true_ [x] | isUnboxableCon con -> x - xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con,xs)) + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, satJExpr Nothing <$> xs)) -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig @@ -97,23 +98,11 @@ -> Maybe JExpr -> JExpr allocDynamicE inline_alloc entry free cc - | inline_alloc || length free > 24 = newClosure $ Closure - { clEntry = entry - , clField1 = fillObj1 - , clField2 = fillObj2 - , clMeta = ValExpr (JInt 0) - , clCC = cc - } + | inline_alloc || length free > jsClosureCount + = newClosure $ mkClosure entry free (ValExpr (JInt 0)) cc | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc) where allocFun = allocClsA (length free) - (fillObj1,fillObj2) - = case free of - [] -> (null_, null_) - [x] -> (x,null_) - [x,y] -> (x,y) - (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs))) - dataFields = map (mkFastString . ('d':) . show) [(1::Int)..] -- | Allocate a dynamic object allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs --- a/compiler/GHC/StgToJS/Deps.hs +++ b/compiler/GHC/StgToJS/Deps.hs @@ -22,11 +22,11 @@ import GHC.Prelude -import GHC.StgToJS.Object as Object +import GHC.StgToJS.Object import GHC.StgToJS.Types import GHC.StgToJS.Ids -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.Types.Id import GHC.Types.Unique @@ -45,20 +45,19 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.IntSet as IS -import qualified GHC.Data.Word64Map as WM -import GHC.Data.Word64Map (Word64Map) +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) import Data.Array import Data.Either -import Data.Word import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.State data DependencyDataCache = DDC - { ddcModule :: !(Word64Map Unit) -- ^ Unique Module -> Unit - , ddcId :: !(Word64Map Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) - , ddcOther :: !(Map OtherSymb Object.ExportedFun) + { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit + , ddcId :: !(IntMap ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules) + , ddcOther :: !(Map OtherSymb ExportedFun) } -- | Generate module dependency data @@ -69,24 +68,16 @@ :: HasDebugCallStack => Module -> [LinkableUnit] - -> G Object.Deps + -> G BlockInfo genDependencyData mod units = do - -- [(blockindex, blockdeps, required, exported)] ds <- evalStateT (mapM (uncurry oneDep) blocks) - (DDC WM.empty WM.empty M.empty) - return $ Object.Deps - { depsModule = mod - , depsRequired = IS.fromList [ n | (n, _, True, _) <- ds ] - , depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds - , depsBlocks = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) + (DDC IM.empty IM.empty M.empty) + return $ BlockInfo + { bi_module = mod + , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] + , bi_exports = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds + , bi_block_deps = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) } - -- XXX - -- return $ BlockInfo - -- { bi_module = mod - -- , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] - -- , bi_exports = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds - -- , bi_block_deps = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) - -- } where -- Id -> Block unitIdExports :: UniqFM Id Int @@ -107,7 +98,7 @@ -- generate the list of exports and set of dependencies for one unit oneDep :: LinkableUnit -> Int - -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.ExportedFun]) + -> StateT DependencyDataCache G (Int, BlockDeps, Bool, [ExportedFun]) oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps @@ -115,9 +106,10 @@ expi <- mapM lookupExportedId (filter isExportedId idExports) expo <- mapM lookupExportedOther otherExports -- fixme thin deps, remove all transitive dependencies! - let bdeps = Object.BlockDeps - (IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp) - (S.toList . S.fromList $ edi++edo++edp) + let bdeps = BlockDeps + { blockBlockDeps = IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp + , blockFunDeps = S.toList . S.fromList $ edi++edo++edp + } return (n, bdeps, req, expi++expo) idModule :: Id -> Maybe Module @@ -125,7 +117,7 @@ guard (m /= mod) >> return m lookupPseudoIdFun :: Int -> Unique - -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + -> StateT DependencyDataCache G (Either ExportedFun Int) lookupPseudoIdFun _n u = case lookupUFM_Directly unitIdExports u of Just k -> return (Right k) @@ -138,62 +130,62 @@ -- assumes function is internal to the current block if it's -- from teh current module and not in the unitIdExports map. lookupIdFun :: Int -> Id - -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + -> StateT DependencyDataCache G (Either ExportedFun Int) lookupIdFun n i = case lookupUFM unitIdExports i of Just k -> return (Right k) Nothing -> case idModule i of Nothing -> return (Right n) Just m -> let k = getKey . getUnique $ i - addEntry :: StateT DependencyDataCache G Object.ExportedFun + addEntry :: StateT DependencyDataCache G ExportedFun addEntry = do (TxtI idTxt) <- lift (identForId i) lookupExternalFun (Just k) (OtherSymb m idTxt) in if m == mod then pprPanic "local id not found" (ppr m) else Left <$> do - mr <- gets (WM.lookup k . ddcId) + mr <- gets (IM.lookup k . ddcId) maybe addEntry return mr -- get the function for an OtherSymb from the cache, add it if necessary lookupOtherFun :: OtherSymb - -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + -> StateT DependencyDataCache G (Either ExportedFun Int) lookupOtherFun od@(OtherSymb m idTxt) = case M.lookup od unitOtherExports of Just n -> return (Right n) - Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ unpackFS idTxt) + Nothing | m == mod -> pprPanic "genDependencyData.lookupOtherFun: unknown local other id:" (ftext idTxt) Nothing -> Left <$> (maybe (lookupExternalFun Nothing od) return =<< gets (M.lookup od . ddcOther)) - lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedId :: Id -> StateT DependencyDataCache G ExportedFun lookupExportedId i = do (TxtI idTxt) <- lift (identForId i) lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) - lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedOther :: FastString -> StateT DependencyDataCache G ExportedFun lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod -- lookup a dependency to another module, add to the id cache if there's -- an id key, otherwise add to other cache - lookupExternalFun :: Maybe Word64 - -> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun + lookupExternalFun :: Maybe Int + -> OtherSymb -> StateT DependencyDataCache G ExportedFun lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do let mk = getKey . getUnique $ m mpk = moduleUnit m - exp_fun = Object.ExportedFun m (LexicalFastString idTxt) + exp_fun = ExportedFun m (LexicalFastString idTxt) addCache = do ms <- gets ddcModule - let !cache' = WM.insert mk mpk ms + let !cache' = IM.insert mk mpk ms modify (\s -> s { ddcModule = cache'}) pure exp_fun f <- do - mbm <- gets (WM.member mk . ddcModule) + mbm <- gets (IM.member mk . ddcModule) case mbm of False -> addCache True -> pure exp_fun case mbIdKey of Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) }) - Just k -> modify (\s -> s { ddcId = WM.insert k f (ddcId s) }) + Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) }) return f diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs --- a/compiler/GHC/StgToJS/Expr.hs +++ b/compiler/GHC/StgToJS/Expr.hs @@ -30,11 +30,13 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.JS.Transform import GHC.JS.Make import GHC.StgToJS.Apply import GHC.StgToJS.Arg +import GHC.StgToJS.Closure import GHC.StgToJS.ExprCtx import GHC.StgToJS.FFI import GHC.StgToJS.Heap @@ -45,13 +47,10 @@ import GHC.StgToJS.Prim import GHC.StgToJS.Profiling import GHC.StgToJS.Regs -import GHC.StgToJS.StgUtils -import GHC.StgToJS.CoreUtils import GHC.StgToJS.Utils import GHC.StgToJS.Stack import GHC.StgToJS.Ids -import GHC.Types.Basic import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Set @@ -73,7 +72,6 @@ import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) import qualified Control.Monad.Trans.State.Strict as State import GHC.Data.FastString @@ -147,7 +145,7 @@ ctx' = ctxClearLneFrame ctx assign :: Id -> CgStgRhs -> G (Maybe JStat) - assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr) + assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr _typ) | let strip = snd . stripStgTicksTop (not . tickishIsCode) , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr , StgApp selectee [] <- strip sel_expr @@ -167,7 +165,7 @@ ([tgt], [the_fvj]) -> return $ Just (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj]) _ -> panic "genBind.assign: invalid size" - assign b (StgRhsClosure _ext _ccs _upd [] expr) + assign b (StgRhsClosure _ext _ccs _upd [] expr _typ) | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do d <- declVarsForId b tgt <- varsForId b @@ -179,9 +177,9 @@ addEvalRhs c [] = c addEvalRhs c ((b,r):xs) - | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs - | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs - | otherwise = addEvalRhs c xs + | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | (StgRhsClosure _ _ ReEntrant _ _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | otherwise = addEvalRhs c xs genBindLne :: HasDebugCallStack => ExprCtx @@ -222,7 +220,7 @@ -- is initially set to null, changed to h$blackhole when the thunk is being evaluated. -- genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () -genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) = +genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx vars = ctxLneFrameVars ctx @@ -237,10 +235,10 @@ ]) | otherwise = mempty lvs <- popLneFrame True payloadSize ctx - body <- genBody ctx i R1 args body + body <- genBody ctx R1 args body typ ei@(TxtI eii) <- identForEntryId i sr <- genStaticRefsRhs rhs - let f = JFunc [] (bh <> lvs <> body) + let f = (bh <> lvs <> body) emitClosureInfo $ ClosureInfo ei (CIRegs 0 $ concatMap idVt args) @@ -249,8 +247,8 @@ map (stackSlotType . fst) (ctxLneFrameVars ctx)) CIStackFrame sr - emitToplevel (ei ||= toJExpr f) -genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do + emitToplevel (jFunction ei [] f) +genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx ei@(TxtI _eii) <- identForEntryId i -- di <- varForDataConWorker con @@ -258,18 +256,17 @@ p <- popLneFrame True payloadSize ctx args' <- concatMapM genArg args ac <- allocCon ii con cc args' - emitToplevel (ei ||= toJExpr (JFunc [] - (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + emitToplevel (jFunction ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) -- | Generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () genEntry _ _i StgRhsCon {} = return () -genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do +genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = resetSlots $ do let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body ll <- loadLiveFun live llv <- verifyRuntimeReps live upd <- genUpdFrame upd_flag i - body <- genBody entryCtx i R2 args body + body <- genBody entryCtx R2 args body typ ei@(TxtI eii) <- identForEntryId i et <- genEntryType args setcc <- ifProfiling $ @@ -283,7 +280,7 @@ (fixedLayout $ map (uTypeVt . idType) live) et sr - emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body])) where entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) @@ -301,12 +298,12 @@ -- | Generate the body of an object genBody :: HasDebugCallStack => ExprCtx - -> Id -> StgReg -> [Id] -> CgStgExpr + -> Type -> G JStat -genBody ctx i startReg args e = do +genBody ctx startReg args e typ = do -- load arguments into local variables la <- do args' <- concatMapM genIdArgI args @@ -317,7 +314,7 @@ -- compute PrimReps and their number of slots required to return the result of -- i applied to args. - let res_vars = resultSize args i + let res_vars = resultSize typ -- compute typed expressions for each slot and assign registers let go_var regs = \case @@ -358,22 +355,12 @@ -- In case of failure to determine the type, we default to LiftedRep as it's -- probably what it is. -- -resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)] -resultSize args i = result +resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)] +resultSize ty = result where result = result_reps `zip` result_slots result_slots = fmap (slotCount . primRepSize) result_reps - result_reps = trim_args (unwrapType (idType i)) (length args) - - trim_args t 0 = typePrimRep t - trim_args t n - | Just (_af, _mult, arg, res) <- splitFunTy_maybe t - , nargs <- length (typePrimRepArgs arg) - , assert (n >= nargs) True - = trim_args (unwrapType res) (n - nargs) - | otherwise - = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t) - [LiftedRep] + result_reps = typePrimRep ty -- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function -- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. @@ -395,7 +382,6 @@ go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs) ver j PtrV = v "h$verify_rep_heapobj" [j] ver j IntV = v "h$verify_rep_int" [j] - ver j RtsObjV = v "h$verify_rep_rtsobj" [j] ver j DoubleV = v "h$verify_rep_double" [j] ver j ArrV = v "h$verify_rep_arr" [j] ver _ _ = mempty @@ -484,7 +470,7 @@ | otherwise = do unfloated <- State.gets gsUnfloated let xs = filter (\x -> not (elemUFM x unfloated || - typeLevity_maybe (idType x) == Just Unlifted)) + definitelyUnliftedType (idType x))) (dVarSetElems sv) CIStaticRefs . catMaybes <$> mapM getStaticRef xs where @@ -539,19 +525,19 @@ toCl (i, StgRhsCon cc con []) = do ii <- identForId i Left <$> (return (decl ii) <> allocCon ii con cc []) -} - toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do + toCl (i, StgRhsCon cc con _mui _ticjs [a] _typ) | isUnboxableCon con = do ii <- identForId i ac <- allocCon ii con cc =<< genArg a pure (Left (decl ii <> ac)) -- dynamics - toCl (i, StgRhsCon cc con _mu _ticks ar) = + toCl (i, StgRhsCon cc con _mu _ticks ar _typ) = -- fixme do we need to handle unboxed? Right <$> ((,,,) <$> identForId i <*> varForDataConWorker con <*> concatMapM genArg ar <*> pure cc) - toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) = + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body _typ)) = let live = stgLneLiveExpr cl in Right <$> ((,,,) <$> identForId i <*> varForEntryId i @@ -640,7 +626,7 @@ ++ if prof then [ObjV] else map stackSlotType lneVars) CIStackFrame sr - emitToplevel $ r ||= toJExpr (JFunc [] fun') + emitToplevel $ jFunction r [] fun' return (pushLne <> saveCCS <> pushRet) fst3 ~(x,_,_) = x @@ -910,7 +896,7 @@ DataAlt da -> return $ Just (toJExpr $ dataConTag da) LitAlt l -> genLit l >>= \case [e] -> pure (Just e) - es -> pprPanic "caseCond: expected single-variable literal" (ppr es) + es -> pprPanic "caseCond: expected single-variable literal" (ppr $ satJExpr Nothing <$> es) -- fixme use single tmp var for all branches -- | Load parameters from constructor @@ -1007,7 +993,7 @@ ] (ex:es) -> mconcat [ toJExpr i .^ closureField1_ |= toJExpr ex - , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es)) + , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip (map dataFieldName [1..]) es)) ] | otherwise = case es of [] -> mempty diff --git a/compiler/GHC/StgToJS/FFI.hs b/compiler/GHC/StgToJS/FFI.hs --- a/compiler/GHC/StgToJS/FFI.hs +++ b/compiler/GHC/StgToJS/FFI.hs @@ -11,9 +11,10 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -21,13 +22,12 @@ import GHC.StgToJS.Types import GHC.StgToJS.Literal import GHC.StgToJS.Regs -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Ids import GHC.Types.RepType import GHC.Types.ForeignCall import GHC.Types.Unique.Map -import GHC.Types.Unique.FM import GHC.Stg.Syntax @@ -37,17 +37,12 @@ import GHC.Core.Type hiding (typeSize) import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text) +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) import GHC.Data.FastString import Data.Char import Data.Monoid -import Data.Maybe import qualified Data.List as L -import Control.Monad -import Control.Applicative -import qualified Text.ParserCombinators.ReadP as P genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult) genPrimCall ctx (PrimCall lbl _) args t = do @@ -136,32 +131,8 @@ -> G JStat parseFFIPattern' callback javascriptCc pat t ret args | not javascriptCc = mkApply pat - | otherwise = - if True - then mkApply pat - else do - u <- freshUnique - case parseFfiJME pat u of - Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat - Right expr | not async && length tgt < 2 -> do - (statPre, ap) <- argPlaceholders javascriptCc args - let rp = resultPlaceholders async t ret - env = addListToUFM emptyUFM (rp ++ ap) - if length tgt == 1 - then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr)) - else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr)) - Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++ - " imports with result size 0 or 1.\n" ++ pat - Left _ -> case parseFfiJM pat u of - Left err -> p (show err) - Right stat -> do - let rp = resultPlaceholders async t ret - let cp = callbackPlaceholders callback - (statPre, ap) <- argPlaceholders javascriptCc args - let env = addListToUFM emptyUFM (rp ++ ap ++ cp) - return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace? + | otherwise = mkApply pat where - async = isJust callback tgt = take (typeSize t) ret -- automatic apply, build call and result copy mkApply f @@ -184,33 +155,11 @@ return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as) where f' = toJExpr (TxtI $ mkFastString f) copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs - p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e) - replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr - replaceIdent env i - | isFFIPlaceholder i = fromMaybe err (lookupUFM env i) - | otherwise = ValExpr (JVar i) - where - (TxtI i') = i - err = pprPanic "parseFFIPattern': invalid placeholder, check function type" - (vcat [text pat, ppr i', ppr args, ppr t]) traceCall cs as | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as] | otherwise = mempty --- ident is $N, $N_R, $rN, $rN_R or $r or $c -isFFIPlaceholder :: Ident -> Bool -isFFIPlaceholder (TxtI x) = not (null (P.readP_to_S parser (unpackFS x))) - where - digit = P.satisfy (`elem` ("0123456789" :: String)) - parser = void (P.string "$r" >> P.eof) <|> - void (P.string "$c" >> P.eof) <|> do - _ <- P.char '$' - P.optional (P.char 'r') - _ <- P.many1 digit - P.optional (P.char '_' >> P.many1 digit) - P.eof - -- generate arg to be passed to FFI call, with marshalling JStat to be run -- before the call genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr]) @@ -228,59 +177,8 @@ arg_ty = stgArgType a r = uTypeVt arg_ty --- $1, $2, $3 for single, $1_1, $1_2 etc for dual --- void args not counted -argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)]) -argPlaceholders isJavaScriptCc args = do - (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args - let idents = filter (not . null) idents0 - return $ (mconcat stats, concat - (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..])) - -mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)] -mkPlaceholder undersc prefix aids = - case aids of - [] -> [] - [x] -> [(TxtI . mkFastString $ prefix, x)] - xs@(x:_) -> (TxtI . mkFastString $ prefix, x) : - zipWith (\x m -> (TxtI . mkFastString $ prefix ++ u ++ show m,x)) xs [(1::Int)..] - where u = if undersc then "_" else "" - --- $r for single, $r1,$r2 for dual --- $r1, $r2, etc for ubx tup, void args not counted -resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement -resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback -resultPlaceholders False t rs = - case typeVt (unwrapType t) of - [t'] -> mkUnary (varSize t') - uts -> - let sizes = filter (>0) (map varSize uts) - f _ 0 = [] - f n 1 = [["$r" ++ show n]] - f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k] - where sn = show n - phs = zipWith (\size n -> f n size) sizes [(1::Int)..] - in case sizes of - [n] -> mkUnary n - _ -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (mkFastString i), r)) phs') (concat phs) rs - where - mkUnary 0 = [] - mkUnary 1 = [(TxtI "$r",head rs)] -- single - mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++ - zipWith (\n r -> (TxtI . mkFastString $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs) - -callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)] -callbackPlaceholders Nothing = [] -callbackPlaceholders (Just e) = [((TxtI "$c"), e)] - -parseFfiJME :: String -> Int -> Either String JExpr -parseFfiJME _xs _u = Left "parseFfiJME not yet implemented" - -parseFfiJM :: String -> Int -> Either String JStat -parseFfiJM _xs _u = Left "parseFfiJM not yet implemented" - -saturateFFI :: JMacro a => Int -> a -> a -saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) +saturateFFI :: Int -> JStat -> Sat.JStat +saturateFFI u = satJStat (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack => ExprCtx diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs --- a/compiler/GHC/StgToJS/Heap.hs +++ b/compiler/GHC/StgToJS/Heap.hs @@ -38,7 +38,7 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types import GHC.Data.FastString diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs --- a/compiler/GHC/StgToJS/Ids.hs +++ b/compiler/GHC/StgToJS/Ids.hs @@ -40,10 +40,10 @@ import GHC.StgToJS.Types import GHC.StgToJS.Monad -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Symbols -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.Core.DataCon @@ -111,7 +111,7 @@ = current_module !ident = mkFastStringByteString $ mconcat - [ mkJsSymbolBS exported mod (occNameFS (nameOccName name)) + [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name)) ------------- -- suffixes @@ -131,7 +131,7 @@ , if exported then mempty else let (c,u) = unpkUnique (getUnique i) - in mconcat [BSC.pack ['_',c,'_'], word64BS u] + in mconcat [BSC.pack ['_',c,'_'], intBS u] ] -- | Retrieve the cached Ident for the given Id if there is one. Otherwise make diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs --- a/compiler/GHC/StgToJS/Linker/Linker.hs +++ b/compiler/GHC/StgToJS/Linker/Linker.hs @@ -21,7 +21,17 @@ module GHC.StgToJS.Linker.Linker ( jsLinkBinary + , jsLink , embedJsFile + , staticInitStat + , staticDeclStat + , mkExportedFuns + , mkExportedModFuns + , computeLinkDependencies + , LinkSpec (..) + , LinkPlan (..) + , emptyLinkPlan + , incrementLinkPlan ) where @@ -30,32 +40,37 @@ import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.Optimizer +import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat +import GHC.JS.Transform -import GHC.Driver.Session (DynFlags(..)) +import GHC.Driver.DynFlags (DynFlags(..)) import Language.Haskell.Syntax.Module.Name import GHC.SysTools.Cpp import GHC.SysTools import GHC.Linker.Static.Utils (exeFileName) +import GHC.Linker.Types (Unlinked(..), linkableUnlinked) import GHC.StgToJS.Linker.Types import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt import GHC.StgToJS.Rts.Rts import GHC.StgToJS.Object import GHC.StgToJS.Types hiding (LinkableUnit) import GHC.StgToJS.Symbols -import GHC.StgToJS.Printer import GHC.StgToJS.Arg import GHC.StgToJS.Closure import GHC.Unit.State import GHC.Unit.Env -import GHC.Unit.Home +import GHC.Unit.Home.ModInfo import GHC.Unit.Types import GHC.Unit.Module (moduleStableString) import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.BufHandle import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Logger (Logger, logVerbAtLeast) @@ -71,22 +86,17 @@ import qualified GHC.Data.ShortText as ST import GHC.Data.FastString -import Control.Concurrent.MVar import Control.Monad import Data.Array import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import Data.Function (on) -import Data.IntSet (IntSet) import qualified Data.IntSet as IS import Data.IORef -import Data.List ( partition, nub, intercalate, group, sort - , groupBy, intersperse, - ) +import Data.List ( nub, intercalate, groupBy, intersperse, sortBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe @@ -104,6 +114,10 @@ , getPermissions ) +import GHC.Unit.Finder.Types +import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule) +import GHC.Driver.Config.Finder (initFinderOpts) + data LinkerStats = LinkerStats { bytesPerModule :: !(Map Module Word64) -- ^ number of bytes linked per module , packedMetaDataSize :: !Word64 -- ^ number of bytes for metadata @@ -114,8 +128,12 @@ emptyArchiveState :: IO ArchiveState emptyArchiveState = ArchiveState <$> newIORef M.empty +defaultJsContext :: SDocContext +defaultJsContext = defaultSDocContext{sdocStyle = PprCode} + jsLinkBinary - :: JSLinkConfig + :: FinderCache + -> JSLinkConfig -> StgToJSConfig -> [FilePath] -> Logger @@ -124,7 +142,7 @@ -> [FilePath] -> [UnitId] -> IO () -jsLinkBinary lc_cfg cfg js_srcs logger dflags u_env objs dep_pkgs +jsLinkBinary finder_cache lc_cfg cfg js_srcs logger dflags unit_env objs dep_units | lcNoJSExecutables lc_cfg = return () | otherwise = do -- additional objects to link are passed as FileOption ldInputs... @@ -134,47 +152,56 @@ let objs' = map ObjFile (objs ++ cmdline_js_objs) js_srcs' = js_srcs ++ cmdline_js_srcs - isRoot _ = True + is_root _ = True -- FIXME: we shouldn't consider every function as a root, + -- but only the program entry point (main), either the + -- generated one or coming from an object exe = jsExeFileName dflags - void $ link lc_cfg cfg logger u_env exe mempty dep_pkgs objs' js_srcs' isRoot mempty + -- compute dependencies + let link_spec = LinkSpec + { lks_unit_ids = dep_units + , lks_obj_files = objs' + , lks_obj_root_filter = is_root + , lks_extra_roots = mempty + , lks_extra_js = js_srcs' + } + let finder_opts = initFinderOpts dflags + + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache + + void $ jsLink lc_cfg cfg logger exe link_plan + -- | link and write result to disk (jsexe directory) -link :: JSLinkConfig +jsLink + :: JSLinkConfig -> StgToJSConfig -> Logger - -> UnitEnv -> FilePath -- ^ output file/directory - -> [FilePath] -- ^ include path for home package - -> [UnitId] -- ^ packages to link - -> [LinkedObj] -- ^ the object files we're linking - -> [FilePath] -- ^ extra js files to include - -> (ExportedFun -> Bool) -- ^ functions from the objects to use as roots (include all their deps) - -> Set ExportedFun -- ^ extra symbols to link in + -> LinkPlan -> IO () -link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun extraStaticDeps = do +jsLink lc_cfg cfg logger out link_plan = do -- create output directory createDirectoryIfMissing False out + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "jsLink:") 2 (ppr link_plan) + ------------------------------------------------------------- -- link all Haskell code (program + dependencies) into out.js - -- compute dependencies - (dep_map, dep_units, all_deps, _rts_wired_functions, dep_archives) - <- computeLinkDependencies cfg logger out unit_env units objFiles extraStaticDeps isRootFun - - -- retrieve code for dependencies - mods <- collectDeps dep_map dep_units all_deps + -- retrieve code for Haskell dependencies + mods <- collectModuleCodes link_plan -- LTO + rendering of JS code link_stats <- withBinaryFile (out "out.js") WriteMode $ \h -> - renderLinker h mods jsFiles + renderLinker h (csPrettyRender cfg) mods (lkp_extra_js link_plan) ------------------------------------------------------------- -- dump foreign references file (.frefs) - unless (lcOnlyOut lc_cfg) $ do + when (lcForeignRefs lc_cfg) $ do let frefsFile = "out.frefs" -- frefs = concatMap mc_frefs mods jsonFrefs = mempty -- FIXME: toJson frefs @@ -190,12 +217,12 @@ -- link generated RTS parts into rts.js unless (lcNoRts lc_cfg) $ do - BL.writeFile (out "rts.js") ( BLC.pack rtsDeclsText - <> BLC.pack (rtsText cfg)) + withFile (out "rts.js") WriteMode $ \h -> do + void $ hPutJS (csPrettyRender cfg) h (rts cfg) -- link dependencies' JS files into lib.js withBinaryFile (out "lib.js") WriteMode $ \h -> do - forM_ dep_archives $ \archive_file -> do + forM_ (lkp_archives link_plan) $ \archive_file -> do Ar.Archive entries <- Ar.loadAr archive_file forM_ entries $ \entry -> do case getJsArchiveEntry entry of @@ -204,47 +231,106 @@ B.hPut h bs hPutChar h '\n' - -- link everything together into all.js - when (generateAllJs lc_cfg) $ do + -- link everything together into a runnable all.js + -- only if we link a complete application, + -- no incremental linking and no skipped parts + when (lcCombineAll lc_cfg && not (lcNoRts lc_cfg)) $ do _ <- combineFiles lc_cfg out writeHtml out writeRunMain out writeRunner lc_cfg out writeExterns out +data LinkSpec = LinkSpec + { lks_unit_ids :: [UnitId] + , lks_obj_files :: [LinkedObj] + + , lks_obj_root_filter :: ExportedFun -> Bool + -- ^ Predicate for exported functions in objects to declare as root + + , lks_extra_roots :: Set ExportedFun + -- ^ Extra root functions from loaded units + + , lks_extra_js :: [FilePath] + -- ^ Extra JS files to link + } + +instance Outputable LinkSpec where + ppr s = hang (text "LinkSpec") 2 $ vcat + [ hcat [text "Unit ids: ", ppr (lks_unit_ids s)] + , hcat [text "Object files:", ppr (lks_obj_files s)] + , text "Object root filter: " + , hcat [text "Extra roots: ", ppr (lks_extra_roots s)] + , hang (text "Extra JS:") 2 (vcat (fmap text (lks_extra_js s))) + ] + +emptyLinkPlan :: LinkPlan +emptyLinkPlan = LinkPlan + { lkp_block_info = mempty + , lkp_dep_blocks = mempty + , lkp_archives = mempty + , lkp_extra_js = mempty + } + +-- | Given a `base` link plan (assumed to be already linked) and a `new` link +-- plan, compute `(diff, total)` link plans. +-- +-- - `diff` is the incremental link plan to get from `base` to `total` +-- - `total` is the total link plan as if `base` and `new` were linked at once +incrementLinkPlan :: LinkPlan -> LinkPlan -> (LinkPlan, LinkPlan) +incrementLinkPlan base new = (diff,total) + where + total = LinkPlan + { lkp_block_info = M.union (lkp_block_info base) (lkp_block_info new) + , lkp_dep_blocks = S.union (lkp_dep_blocks base) (lkp_dep_blocks new) + , lkp_archives = S.union (lkp_archives base) (lkp_archives new) + , lkp_extra_js = S.union (lkp_extra_js base) (lkp_extra_js new) + } + diff = LinkPlan + { lkp_block_info = lkp_block_info new -- block info from "new" contains all we need to load new blocks + , lkp_dep_blocks = S.difference (lkp_dep_blocks new) (lkp_dep_blocks base) + , lkp_archives = S.difference (lkp_archives new) (lkp_archives base) + , lkp_extra_js = S.difference (lkp_extra_js new) (lkp_extra_js base) + } + + computeLinkDependencies :: StgToJSConfig - -> Logger - -> String -> UnitEnv - -> [UnitId] - -> [LinkedObj] - -> Set ExportedFun - -> (ExportedFun -> Bool) - -> IO (Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit, Set ExportedFun, [FilePath]) -computeLinkDependencies cfg logger target unit_env units objFiles extraStaticDeps isRootFun = do + -> LinkSpec + -> FinderOpts + -> FinderCache + -> IO LinkPlan +computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache = do - (objDepsMap, objRequiredUnits) <- loadObjDeps objFiles + let units = lks_unit_ids link_spec + let obj_files = lks_obj_files link_spec + let extra_roots = lks_extra_roots link_spec + let obj_is_root = lks_obj_root_filter link_spec - let roots = S.fromList . filter isRootFun $ concatMap (M.keys . depsHaskellExported . fst) (M.elems objDepsMap) - rootMods = map (moduleNameString . moduleName . head) . group . sort . map funModule . S.toList $ roots - objPkgs = map moduleUnitId $ nub (M.keys objDepsMap) + -- Process: + -- 1) Find new required linkables (object files, libraries, etc.) for all + -- transitive dependencies + -- 2) Load ObjBlockInfo from them and cache them + -- 3) Compute ObjBlock dependencies and return the link plan - when (logVerbAtLeast logger 2) $ void $ do - compilationProgressMsg logger $ hcat - [ text "Linking ", text target, text " (", text (intercalate "," rootMods), char ')' ] - compilationProgressMsg logger $ hcat - [ text "objDepsMap ", ppr objDepsMap ] - compilationProgressMsg logger $ hcat - [ text "objFiles ", ppr objFiles ] + -- TODO (#23013): currently we directly compute the ObjBlock dependencies and + -- find/load linkable on-demand when a module is missing. + + (objs_block_info, objs_required_blocks) <- loadObjBlockInfo obj_files + + let obj_roots = S.fromList . filter obj_is_root $ concatMap (M.keys . bi_exports . lbi_info) (M.elems objs_block_info) + obj_units = map moduleUnitId $ nub (M.keys objs_block_info) + let (rts_wired_units, rts_wired_functions) = rtsDeps units -- all the units we want to link together, without their dependencies - let root_units = filter (/= mainUnitId) + let root_units = filter (/= ue_currentUnit unit_env) + $ filter (/= interactiveUnitId) $ nub - $ rts_wired_units ++ reverse objPkgs ++ reverse units + $ rts_wired_units ++ reverse obj_units ++ reverse units -- all the units we want to link together, including their dependencies, -- preload units, and backpack instantiations @@ -253,32 +339,78 @@ let all_units = fmap unitId all_units_infos dep_archives <- getPackageArchives cfg unit_env all_units - env <- newGhcjsEnv - (archsDepsMap, archsRequiredUnits) <- loadArchiveDeps env dep_archives - - when (logVerbAtLeast logger 2) $ - logInfo logger $ hang (text "Linking with archives:") 2 (vcat (fmap text dep_archives)) + (archives_block_info, archives_required_blocks) <- loadArchiveBlockInfo dep_archives -- compute dependencies - let dep_units = all_units ++ [homeUnitId (ue_unsafeHomeUnit $ unit_env)] - dep_map = objDepsMap `M.union` archsDepsMap - excluded_units = S.empty - dep_fun_roots = roots `S.union` rts_wired_functions `S.union` extraStaticDeps - dep_unit_roots = archsRequiredUnits ++ objRequiredUnits + let block_info = objs_block_info `M.union` archives_block_info + dep_fun_roots = obj_roots `S.union` rts_wired_functions `S.union` extra_roots - all_deps <- getDeps (fmap fst dep_map) excluded_units dep_fun_roots dep_unit_roots + -- read transitive dependencies + new_required_blocks_var <- newIORef [] + let load_info mod = do + -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps. + linkable <- case lookupHugByModule mod (ue_home_unit_graph unit_env) of + Nothing -> + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + case ue_homeUnit unit_env of + Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod) + Just home_unit -> do + mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) + case mb_stuff of + Found loc mod -> found loc mod + _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) + where + found loc mod = do { + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> pprPanic "getDeps: Couldn't find linkable for module: " (pprModule mod) ; + Just lnk -> pure lnk + }} - when (logVerbAtLeast logger 2) $ - logInfo logger $ hang (text "Units to link:") 2 (vcat (fmap ppr dep_units)) - -- logInfo logger $ hang (text "All deps:") 2 (vcat (fmap ppr (S.toList all_deps))) + Just mod_info -> case homeModInfoObject mod_info of + Nothing -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod) + Just lnk -> pure lnk - return (dep_map, dep_units, all_deps, rts_wired_functions, dep_archives) + case linkableUnlinked linkable of + [DotO p] -> do + (bis, req_b) <- loadObjBlockInfo [ObjFile p] + -- Store new required blocks in IORef + modifyIORef new_required_blocks_var ((++) req_b) + case M.lookup mod bis of + Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod) + Just bi -> pure bi + ul -> pprPanic "getDeps: Unrecognized linkable for home-module: " + (vcat [ pprModule mod + , ppr ul]) + -- required blocks have no dependencies, so don't have to use them as roots in + -- the traversal + (updated_block_info, transitive_deps) <- getDeps block_info load_info dep_fun_roots mempty + new_required_blocks <- readIORef new_required_blocks_var + let required_blocks = S.fromList $ mconcat + [ archives_required_blocks + , objs_required_blocks + , new_required_blocks + ] + + let all_deps = S.union transitive_deps required_blocks + + let plan = LinkPlan + { lkp_block_info = updated_block_info + , lkp_dep_blocks = all_deps + , lkp_archives = S.fromList dep_archives + , lkp_extra_js = S.fromList (lks_extra_js link_spec) + } + + return plan + + -- | Compiled module data ModuleCode = ModuleCode { mc_module :: !Module - , mc_js_code :: !JStat + , mc_js_code :: !Sat.JStat , mc_exports :: !B.ByteString -- ^ rendered exports , mc_closures :: ![ClosureInfo] , mc_statics :: ![StaticInfo] @@ -291,29 +423,43 @@ -- up into global "metadata" for the whole link. data CompactedModuleCode = CompactedModuleCode { cmc_module :: !Module - , cmc_js_code :: !JStat + , cmc_js_code :: !Sat.JStat , cmc_exports :: !B.ByteString -- ^ rendered exports } +-- | Output JS statements and return the output size in bytes. +hPutJS :: Bool -> Handle -> Sat.JStat -> IO Integer +hPutJS render_pretty h = \case + Sat.BlockStat [] -> pure 0 + x -> do + before <- hTell h + if render_pretty + then do + printSDoc defaultJsContext (Ppr.PageMode True) h (pretty render_pretty x) + else do + bh <- newBufHandle h + bPutHDoc bh defaultJsContext (line $ pretty render_pretty x) + bFlush bh + -- Append an empty line to correctly end the file in a newline + hPutChar h '\n' + after <- hTell h + pure $! (after - before) + -- | Link modules and pretty-print them into the given Handle renderLinker :: Handle + -> Bool -- ^ should we render readable JS for debugging? -> [ModuleCode] -- ^ linked code per module - -> [FilePath] -- ^ additional JS files + -> Set FilePath -- ^ additional JS files -> IO LinkerStats -renderLinker h mods jsFiles = do +renderLinker h render_pretty mods js_files = do -- link modules let (compacted_mods, meta) = linkModules mods let putBS = B.hPut h - putJS x = do - before <- hTell h - Ppr.printLeftRender h (pretty x) - hPutChar h '\n' - after <- hTell h - pure $! (after - before) + putJS = hPutJS render_pretty h --------------------------------------------------------- -- Pretty-print JavaScript code for all the dependencies. @@ -329,13 +475,13 @@ pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS meta + !meta_length <- fromIntegral <$> putJS (jsOptimize $ satJStat Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods -- explicit additional JS files - mapM_ (\i -> B.readFile i >>= putBS) jsFiles + mapM_ (\i -> B.readFile i >>= putBS) (S.toList js_files) -- stats let link_stats = LinkerStats @@ -468,99 +614,147 @@ writeExterns out = writeFile (out "all.js.externs") $ unpackFS rtsExterns --- | get all dependencies for a given set of roots -getDeps :: Map Module Deps -- ^ loaded deps - -> Set LinkableUnit -- ^ don't link these blocks - -> Set ExportedFun -- ^ start here - -> [LinkableUnit] -- ^ and also link these - -> IO (Set LinkableUnit) -getDeps loaded_deps base fun startlu = go' S.empty (S.fromList startlu) (S.toList fun) +-- | Get all block dependencies for a given set of roots +-- +-- Returns the update block info map and the blocks. +getDeps :: Map Module LocatedBlockInfo -- ^ Block info per module + -> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing + -> Set ExportedFun -- ^ start here + -> Set BlockRef -- ^ and also link these + -> IO (Map Module LocatedBlockInfo, Set BlockRef) +getDeps init_infos load_info root_funs root_blocks = traverse_funs init_infos S.empty root_blocks (S.toList root_funs) where - go :: Set LinkableUnit - -> Set LinkableUnit - -> IO (Set LinkableUnit) - go result open = case S.minView open of - Nothing -> return result - Just (lu@(lmod,n), open') -> - case M.lookup lmod loaded_deps of - Nothing -> pprPanic "getDeps.go: object file not loaded for: " (pprModule lmod) - Just (Deps _ _ _ b) -> - let block = b!n - result' = S.insert lu result - in go' result' - (addOpen result' open' $ - map (lmod,) (blockBlockDeps block)) (blockFunDeps block) + -- A block may depend on: + -- 1. other blocks from the same module + -- 2. exported functions from another module + -- + -- Process: + -- 1. We use the BlockInfos to find the block corresponding to every + -- exported root functions. + -- + -- 2. We had these blocks to the set of root_blocks if they aren't already + -- added to the result. + -- + -- 3. Then we traverse the root_blocks to find their dependencies and we + -- add them to root_blocks (if they aren't already added to the result) and + -- to root_funs. + -- + -- 4. back to 1 - go' :: Set LinkableUnit - -> Set LinkableUnit - -> [ExportedFun] - -> IO (Set LinkableUnit) - go' result open [] = go result open - go' result open (f:fs) = - let key = funModule f - in case M.lookup key loaded_deps of - Nothing -> pprPanic "getDeps.go': object file not loaded for: " $ pprModule key - Just (Deps _m _r e _b) -> - let lun :: Int - lun = fromMaybe (pprPanic "exported function not found: " $ ppr f) - (M.lookup f e) - lu = (key, lun) - in go' result (addOpen result open [lu]) fs + lookup_info infos mod = case M.lookup mod infos of + Just info -> pure (infos, lbi_info info) + Nothing -> do + -- load info and update cache with it + info <- load_info mod + pure (M.insert mod info infos, lbi_info info) - addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit] - -> Set LinkableUnit - addOpen result open newUnits = - let alreadyLinked s = S.member s result || - S.member s open || - S.member s base - in open `S.union` S.fromList (filter (not . alreadyLinked) newUnits) + traverse_blocks + :: Map Module LocatedBlockInfo + -> Set BlockRef + -> Set BlockRef + -> IO (Map Module LocatedBlockInfo, Set BlockRef) + traverse_blocks infos result open = case S.minView open of + Nothing -> return (infos, result) + Just (ref, open') -> do + let mod = block_ref_mod ref + !(infos',info) <- lookup_info infos mod + let block = bi_block_deps info ! block_ref_idx ref + result' = S.insert ref result + to_block_ref i = BlockRef + { block_ref_mod = mod + , block_ref_idx = i + } + traverse_funs infos' result' + (addOpen result' open' $ + map to_block_ref (blockBlockDeps block)) (blockFunDeps block) + traverse_funs + :: Map Module LocatedBlockInfo + -> Set BlockRef + -> Set BlockRef + -> [ExportedFun] + -> IO (Map Module LocatedBlockInfo, Set BlockRef) + traverse_funs infos result open = \case + [] -> traverse_blocks infos result open + (f:fs) -> do + let mod = funModule f + -- lookup module block info for the module that exports the function + !(infos',info) <- lookup_info infos mod + -- lookup block index associated to the function in the block info + case M.lookup f (bi_exports info) of + Nothing -> pprPanic "exported function not found: " $ ppr f + Just idx -> do + let fun_block_ref = BlockRef + { block_ref_mod = mod + , block_ref_idx = idx + } + -- always add the module "global block" when we link a module + let global_block_ref = BlockRef + { block_ref_mod = mod + , block_ref_idx = 0 + } + traverse_funs infos' result (addOpen result open [fun_block_ref,global_block_ref]) fs + + -- extend the open block set with new blocks that are not already in the + -- result block set nor in the open block set. + addOpen + :: Set BlockRef + -> Set BlockRef + -> [BlockRef] + -> Set BlockRef + addOpen result open new_blocks = + let alreadyLinked s = S.member s result || S.member s open + in open `S.union` S.fromList (filter (not . alreadyLinked) new_blocks) + -- | collect dependencies for a set of roots -collectDeps :: Map Module (Deps, DepsLocation) -- ^ Dependency map - -> [UnitId] -- ^ packages, code linked in this order - -> Set LinkableUnit -- ^ All dependencides - -> IO [ModuleCode] -collectDeps mod_deps packages all_deps = do +collectModuleCodes :: LinkPlan -> IO [ModuleCode] +collectModuleCodes link_plan = do - -- read ghc-prim first, since we depend on that for static initialization - let packages' = uncurry (++) $ partition (== primUnitId) (nub packages) + let block_info = lkp_block_info link_plan + let blocks = lkp_dep_blocks link_plan - units_by_module :: Map Module IntSet - units_by_module = M.fromListWith IS.union $ - map (\(m,n) -> (m, IS.singleton n)) (S.toList all_deps) + -- we're going to load all the blocks. Instead of doing this randomly, we + -- group them by module first. + let module_blocks :: Map Module BlockIds + module_blocks = M.fromListWith IS.union $ + map (\ref -> (block_ref_mod ref, IS.singleton (block_ref_idx ref))) (S.toList blocks) - mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)] - mod_deps_bypkg = M.fromListWith (++) - (map (\(m,v) -> (moduleUnitId m,[v])) (M.toList mod_deps)) + -- GHCJS had this comment: "read ghc-prim first, since we depend on that for + -- static initialization". Not sure if it's still true as we haven't ported + -- the compactor yet. Still we sort to read ghc-prim blocks first just in + -- case. + let pred x = moduleUnitId (fst x) == primUnitId + cmp x y = case (pred x, pred y) of + (True,False) -> LT + (False,True) -> GT + (True,True) -> EQ + (False,False) -> EQ + sorted_module_blocks :: [(Module,BlockIds)] + sorted_module_blocks = sortBy cmp (M.toList module_blocks) + + -- load blocks ar_state <- emptyArchiveState - fmap (catMaybes . concat) . forM packages' $ \pkg -> - mapM (uncurry $ extractDeps ar_state units_by_module) - (fromMaybe [] $ M.lookup pkg mod_deps_bypkg) + forM sorted_module_blocks $ \(mod,bids) -> do + case M.lookup mod block_info of + Nothing -> pprPanic "collectModuleCodes: couldn't find block info for module" (ppr mod) + Just lbi -> extractBlocks ar_state lbi bids -extractDeps :: ArchiveState - -> Map Module IntSet - -> Deps - -> DepsLocation - -> IO (Maybe ModuleCode) -extractDeps ar_state units deps loc = - case M.lookup mod units of - Nothing -> return Nothing - Just mod_units -> Just <$> do - let selector n _ = fromIntegral n `IS.member` mod_units || isGlobalUnit (fromIntegral n) - case loc of - ObjectFile fp -> do - us <- readObjectUnits fp selector - pure (collectCode us) - ArchiveFile a -> do - obj <- readArObject ar_state mod a - us <- getObjectUnits obj selector - pure (collectCode us) - InMemory _n obj -> do - us <- getObjectUnits obj selector - pure (collectCode us) +extractBlocks :: ArchiveState -> LocatedBlockInfo -> BlockIds -> IO ModuleCode +extractBlocks ar_state lbi blocks = do + case lbi_loc lbi of + ObjectFile fp -> do + us <- readObjectBlocks fp blocks + pure (collectCode us) + ArchiveFile a -> do + obj <- readArObject ar_state mod a + us <- getObjectBlocks obj blocks + pure (collectCode us) + InMemory _n obj -> do + us <- getObjectBlocks obj blocks + pure (collectCode us) where - mod = depsModule deps + mod = bi_module (lbi_info lbi) newline = BC.pack "\n" mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw mk_js_code = mconcat . map oiStat @@ -692,40 +886,32 @@ -- | Given a @UnitId@, a module name, and a set of symbols in the module, -- package these into an @ExportedFun@. mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun] -mkExportedFuns uid mod_name symbols = map mk_fun symbols +mkExportedFuns uid mod_name symbols = mkExportedModFuns mod names where mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name) - mk_fun sym = ExportedFun mod (LexicalFastString (mkJsSymbol True mod sym)) + names = map (mkJsSymbol True mod) symbols +-- | Given a @Module@ and a set of symbols in the module, package these into an +-- @ExportedFun@. +mkExportedModFuns :: Module -> [FastString] -> [ExportedFun] +mkExportedModFuns mod symbols = map mk_fun symbols + where + mk_fun sym = ExportedFun mod (LexicalFastString sym) + -- | read all dependency data from the to-be-linked files -loadObjDeps :: [LinkedObj] -- ^ object files to link - -> IO (Map Module (Deps, DepsLocation), [LinkableUnit]) -loadObjDeps objs = (prepareLoadedDeps . catMaybes) <$> mapM readDepsFromObj objs +loadObjBlockInfo :: [LinkedObj] -- ^ object files to link + -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadObjBlockInfo objs = (prepareLoadedDeps . catMaybes) <$> mapM readBlockInfoFromObj objs -- | Load dependencies for the Linker from Ar -loadArchiveDeps :: GhcjsEnv - -> [FilePath] - -> IO ( Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) -loadArchiveDeps env archives = modifyMVar (linkerArchiveDeps env) $ \m -> - case M.lookup archives' m of - Just r -> return (m, r) - Nothing -> loadArchiveDeps' archives >>= \r -> return (M.insert archives' r m, r) - where - archives' = S.fromList archives - -loadArchiveDeps' :: [FilePath] - -> IO ( Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) -loadArchiveDeps' archives = do +loadArchiveBlockInfo :: [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadArchiveBlockInfo archives = do archDeps <- forM archives $ \file -> do (Ar.Archive entries) <- Ar.loadAr file catMaybes <$> mapM (readEntry file) entries return (prepareLoadedDeps $ concat archDeps) where - readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation)) + readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe LocatedBlockInfo) readEntry ar_file ar_entry = do let bs = Ar.filedata ar_entry bh <- unsafeUnpackBinBuffer bs @@ -733,8 +919,8 @@ Left _ -> pure Nothing -- not a valid object entry Right mod_name -> do obj <- getObjectBody bh mod_name - let !deps = objDeps obj - pure $ Just (deps, ArchiveFile ar_file) + let !info = objBlockInfo obj + pure $ Just (LocatedBlockInfo (ArchiveFile ar_file) info) -- | Predicate to check that an entry in Ar is a JS source -- and to return it without its header @@ -764,29 +950,32 @@ -prepareLoadedDeps :: [(Deps, DepsLocation)] - -> ( Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) -prepareLoadedDeps deps = - let req = concatMap (requiredUnits . fst) deps - depsMap = M.fromList $ map (\d -> (depsModule (fst d), d)) deps - in (depsMap, req) +prepareLoadedDeps :: [LocatedBlockInfo] + -> (Map Module LocatedBlockInfo, [BlockRef]) +prepareLoadedDeps lbis = (module_blocks, must_link) + where + must_link = concatMap (requiredBlocks . lbi_info) lbis + module_blocks = M.fromList $ map (\d -> (bi_module (lbi_info d), d)) lbis -requiredUnits :: Deps -> [LinkableUnit] -requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d) +requiredBlocks :: BlockInfo -> [BlockRef] +requiredBlocks d = map mk_block_ref (IS.toList $ bi_must_link d) + where + mk_block_ref i = BlockRef + { block_ref_mod = bi_module d + , block_ref_idx = i + } --- | read dependencies from an object that might have already been into memory +-- | read block info from an object that might have already been into memory -- pulls in all Deps from an archive -readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation)) -readDepsFromObj = \case +readBlockInfoFromObj :: LinkedObj -> IO (Maybe LocatedBlockInfo) +readBlockInfoFromObj = \case ObjLoaded name obj -> do - let !deps = objDeps obj - pure $ Just (deps,InMemory name obj) + let !info = objBlockInfo obj + pure $ Just (LocatedBlockInfo (InMemory name obj) info) ObjFile file -> do - readObjectDeps file >>= \case + readObjectBlockInfo file >>= \case Nothing -> pure Nothing - Just deps -> pure $ Just (deps,ObjectFile file) + Just info -> pure $ Just (LocatedBlockInfo (ObjectFile file) info) -- | Embed a JS file into a .o file diff --git a/compiler/GHC/StgToJS/Linker/Opt.hs b/compiler/GHC/StgToJS/Linker/Opt.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Opt.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Opt +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Stability : experimental +-- +-- Optimization pass at link time +-- +-- +-- +----------------------------------------------------------------------------- +module GHC.StgToJS.Linker.Opt + ( pretty + , optRenderJs + ) +where + +import GHC.Prelude +import GHC.Int +import GHC.Exts + +import GHC.JS.Syntax +import GHC.JS.Ppr + +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.List (sortOn) +import Data.Char (isAlpha,isDigit,ord) +import qualified Data.ByteString.Short as SBS + +pretty :: JsRender doc => Bool -> JStat -> doc +pretty render_pretty = \case + BlockStat [] -> empty + s | render_pretty -> jsToDocR defaultRenderJs [s] + | otherwise -> jsToDocR optRenderJs [s] + -- render as a list of statements to ensure that + -- semicolons are added. + +-- | Render JS with code size minimization enabled +optRenderJs :: RenderJs doc +optRenderJs = defaultRenderJs + { renderJsV = ghcjsRenderJsV + , renderJsS = ghcjsRenderJsS + , renderJsI = ghcjsRenderJsI + } + +hdd :: SBS.ShortByteString +hdd = SBS.pack (map (fromIntegral . ord) "h$$") + +ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc +ghcjsRenderJsI _ (TxtI fs) + -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by + -- name in user code, only in compiled code. Hence we can rename them if we do + -- it consistently in all the linked code. + -- + -- These symbols are usually very large because their name includes the + -- unit-id, the module name, and some unique number. So we rename these + -- symbols with a much shorter globally unique number. + -- + -- Here we reuse their FastString unique for this purpose! Note that it only + -- works if we pretty-print all the JS code linked together at once, which we + -- currently do. GHCJS used to maintain a CompactorState to support + -- incremental linking: it contained the mapping between original symbols and + -- their renaming. + | hdd `SBS.isPrefixOf` fastStringToShortByteString fs + , u <- uniqueOfFS fs + = text "h$$" <> hexDoc (fromIntegral u) + | otherwise + = ftext fs + +-- | Render as an hexadecimal number in reversed order (because it's faster and we +-- don't care about the actual value). +hexDoc :: IsLine doc => Word -> doc +hexDoc 0 = char '0' +hexDoc v = text $ go v + where + sym (I# i) = C# (indexCharOffAddr# chars i) + chars = "0123456789abcdef"# + go = \case + 0 -> [] + n -> sym (fromIntegral (n .&. 0x0F)) + : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) + : go (n `shiftR` 8) + + + + +-- attempt to resugar some of the common constructs +ghcjsRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s + +-- don't quote keys in our object literals, so closure compiler works +ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc +ghcjsRenderJsV r (JHash m) + | isNullUniqMap m = text "{}" + | otherwise = braceNest . fsep . punctuate comma . + map (\(x,y) -> quoteIfRequired x <> colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here because + -- we sort the elements lexically + . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m + where + quoteIfRequired :: IsLine doc => FastString -> doc + quoteIfRequired x + | isUnquotedKey x = ftext x + | otherwise = char '\'' <> ftext x <> char '\'' + + isUnquotedKey :: FastString -> Bool + isUnquotedKey fs = case unpackFS fs of + [] -> False + s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs) + + validFirstIdent c = c == '_' || c == '$' || isAlpha c + validOtherIdent c = isAlpha c || isDigit c + +ghcjsRenderJsV r v = renderJsV defaultRenderJs r v diff --git a/compiler/GHC/StgToJS/Linker/Types.hs b/compiler/GHC/StgToJS/Linker/Types.hs deleted file mode 100644 --- a/compiler/GHC/StgToJS/Linker/Types.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Linker.Types --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Josh Meredith --- Stability : experimental --- ------------------------------------------------------------------------------ - -module GHC.StgToJS.Linker.Types - ( GhcjsEnv (..) - , newGhcjsEnv - , JSLinkConfig (..) - , defaultJSLinkConfig - , generateAllJs - , LinkedObj (..) - , LinkableUnit - ) -where - -import GHC.StgToJS.Object - -import GHC.Unit.Types -import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr) - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Set (Set) - -import Control.Concurrent.MVar - -import System.IO - -import Prelude - --------------------------------------------------------------------------------- --- Linker Config --------------------------------------------------------------------------------- - -data JSLinkConfig = JSLinkConfig - { lcNoJSExecutables :: Bool - , lcNoHsMain :: Bool - , lcOnlyOut :: Bool - , lcNoRts :: Bool - , lcNoStats :: Bool - } - --- | we generate a runnable all.js only if we link a complete application, --- no incremental linking and no skipped parts -generateAllJs :: JSLinkConfig -> Bool -generateAllJs s = not (lcOnlyOut s) && not (lcNoRts s) - -defaultJSLinkConfig :: JSLinkConfig -defaultJSLinkConfig = JSLinkConfig - { lcNoJSExecutables = False - , lcNoHsMain = False - , lcOnlyOut = False - , lcNoRts = False - , lcNoStats = False - } - --------------------------------------------------------------------------------- --- Linker Environment --------------------------------------------------------------------------------- - --- | A @LinkableUnit@ is a pair of a module and the index of the block in the --- object file -type LinkableUnit = (Module, Int) - --- | An object file that's either already in memory (with name) or on disk -data LinkedObj - = ObjFile FilePath -- ^ load from this file - | ObjLoaded String Object -- ^ already loaded: description and payload - -instance Outputable LinkedObj where - ppr = \case - ObjFile fp -> hsep [text "ObjFile", text fp] - ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)] - -data GhcjsEnv = GhcjsEnv - { linkerArchiveDeps :: MVar (Map (Set FilePath) - (Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) - ) - } - --- | return a fresh @GhcjsEnv@ -newGhcjsEnv :: IO GhcjsEnv -newGhcjsEnv = GhcjsEnv <$> newMVar M.empty diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs --- a/compiler/GHC/StgToJS/Linker/Utils.hs +++ b/compiler/GHC/StgToJS/Linker/Utils.hs @@ -41,6 +41,7 @@ import Prelude import GHC.Platform +import GHC.Utils.Misc import Data.List (isPrefixOf) import System.IO import Data.Char (isSpace) @@ -303,7 +304,7 @@ parseJsOptions :: String -> [JSOption] parseJsOptions xs = go xs where - trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + trim = dropWhileEndLE isSpace . dropWhile isSpace go [] = [] go xs = let (tok, rest) = break (== ',') xs tok' = trim tok diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs --- a/compiler/GHC/StgToJS/Literal.hs +++ b/compiler/GHC/StgToJS/Literal.hs @@ -9,7 +9,7 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types @@ -20,7 +20,6 @@ import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic -import GHC.Types.RepType import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable @@ -93,26 +92,7 @@ LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) , IntLit 0 ] - LitRubbish _ rep -> - let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep - in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants] - LiftedRep -> pure [ NullLit ] - UnliftedRep -> pure [ NullLit ] - VoidRep -> pure [ ] - AddrRep -> pure [ NullLit, IntLit 0 ] - IntRep -> pure [ IntLit 0 ] - Int8Rep -> pure [ IntLit 0 ] - Int16Rep -> pure [ IntLit 0 ] - Int32Rep -> pure [ IntLit 0 ] - Int64Rep -> pure [ IntLit 0, IntLit 0 ] - WordRep -> pure [ IntLit 0 ] - Word8Rep -> pure [ IntLit 0 ] - Word16Rep -> pure [ IntLit 0 ] - Word32Rep -> pure [ IntLit 0 ] - Word64Rep -> pure [ IntLit 0, IntLit 0 ] - FloatRep -> pure [ DoubleLit (SaneDouble 0) ] - DoubleRep -> pure [ DoubleLit (SaneDouble 0) ] - VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) + l -> pprPanic "genStaticLit" (ppr l) -- make an unsigned 32 bit number from this unsigned one, lower 32 bits toU32Expr :: Integer -> JExpr diff --git a/compiler/GHC/StgToJS/Monad.hs b/compiler/GHC/StgToJS/Monad.hs --- a/compiler/GHC/StgToJS/Monad.hs +++ b/compiler/GHC/StgToJS/Monad.hs @@ -24,7 +24,8 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs deleted file mode 100644 --- a/compiler/GHC/StgToJS/Object.hs +++ /dev/null @@ -1,622 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- only for DB.Binary instances on Module -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Object --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Sylvain Henry --- Jeffrey Young --- Luite Stegeman --- Josh Meredith --- Stability : experimental --- --- Serialization/deserialization of binary .o files for the JavaScript backend --- The .o files contain dependency information and generated code. --- All strings are mapped to a central string table, which helps reduce --- file size and gives us efficient hash consing on read --- --- Binary intermediate JavaScript object files: --- serialized [Text] -> ([ClosureInfo], JStat) blocks --- --- file layout: --- - magic "GHCJSOBJ" --- - compiler version tag --- - module name --- - offsets of string table --- - dependencies --- - offset of the index --- - unit infos --- - index --- - string table --- ------------------------------------------------------------------------------ - -module GHC.StgToJS.Object - ( putObject - , getObjectHeader - , getObjectBody - , getObject - , readObject - , getObjectUnits - , readObjectUnits - , readObjectDeps - , isGlobalUnit - , isJsObjectFile - , Object(..) - , IndexEntry(..) - , Deps (..), BlockDeps (..), DepsLocation (..) - , ExportedFun (..) - ) -where - -import GHC.Prelude - -import Control.Monad - -import Data.Array -import Data.Int -import Data.IntSet (IntSet) -import qualified Data.IntSet as IS -import Data.List (sortOn) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Word -import Data.Char -import Foreign.Storable -import Foreign.Marshal.Array -import System.IO - -import GHC.Settings.Constants (hiVersion) - -import GHC.JS.Syntax -import GHC.StgToJS.Types - -import GHC.Unit.Module - -import GHC.Data.FastString - -import GHC.Types.Unique.Map -import GHC.Float (castDoubleToWord64, castWord64ToDouble) - -import GHC.Utils.Binary hiding (SymbolTable) -import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep) -import GHC.Utils.Monad (mapMaybeM) - --- | An object file -data Object = Object - { objModuleName :: !ModuleName - -- ^ name of the module - , objHandle :: !BinHandle - -- ^ BinHandle that can be used to read the ObjUnits - , objPayloadOffset :: !(Bin ObjUnit) - -- ^ Offset of the payload (units) - , objDeps :: !Deps - -- ^ Dependencies - , objIndex :: !Index - -- ^ The Index, serialed unit indices and their linkable units - } - -type BlockId = Int -type BlockIds = IntSet - --- | dependencies for a single module -data Deps = Deps - { depsModule :: !Module - -- ^ module - , depsRequired :: !BlockIds - -- ^ blocks that always need to be linked when this object is loaded (e.g. - -- everything that contains initializer code or foreign exports) - , depsHaskellExported :: !(Map ExportedFun BlockId) - -- ^ exported Haskell functions -> block - , depsBlocks :: !(Array BlockId BlockDeps) - -- ^ info about each block - } - -instance Outputable Deps where - ppr d = vcat - [ hcat [ text "module: ", pprModule (depsModule d) ] - , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ] - ] - --- | Where are the dependencies -data DepsLocation - = ObjectFile FilePath -- ^ In an object file at path - | ArchiveFile FilePath -- ^ In a Ar file at path - | InMemory String Object -- ^ In memory - -instance Outputable DepsLocation where - ppr = \case - ObjectFile fp -> hsep [text "ObjectFile", text fp] - ArchiveFile fp -> hsep [text "ArchiveFile", text fp] - InMemory s o -> hsep [text "InMemory", text s, ppr (objModuleName o)] - -data BlockDeps = BlockDeps - { blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object - , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects - -- , blockForeignExported :: [ExpFun] - -- , blockForeignImported :: [ForeignRef] - } - -{- | we use the convention that the first unit (0) is a module-global - unit that's always included when something from the module - is loaded. everything in a module implicitly depends on the - global block. the global unit itself can't have dependencies - -} -isGlobalUnit :: Int -> Bool -isGlobalUnit n = n == 0 - --- | Exported Functions -data ExportedFun = ExportedFun - { funModule :: !Module -- ^ The module containing the function - , funSymbol :: !LexicalFastString -- ^ The function - } deriving (Eq, Ord) - -instance Outputable ExportedFun where - ppr (ExportedFun m f) = vcat - [ hcat [ text "module: ", pprModule m ] - , hcat [ text "symbol: ", ppr f ] - ] - --- | Write an ObjUnit, except for the top level symbols which are stored in the --- index -putObjUnit :: BinHandle -> ObjUnit -> IO () -putObjUnit bh (ObjUnit _syms b c d e f g) = do - put_ bh b - put_ bh c - lazyPut bh d - put_ bh e - put_ bh f - put_ bh g - --- | Read an ObjUnit and associate it to the given symbols (that must have been --- read from the index) -getObjUnit :: [FastString] -> BinHandle -> IO ObjUnit -getObjUnit syms bh = do - b <- get bh - c <- get bh - d <- lazyGet bh - e <- get bh - f <- get bh - g <- get bh - pure $ ObjUnit - { oiSymbols = syms - , oiClInfo = b - , oiStatic = c - , oiStat = d - , oiRaw = e - , oiFExports = f - , oiFImports = g - } - - --- | A tag that determines the kind of payload in the .o file. See --- @StgToJS.Linker.Arhive.magic@ for another kind of magic -magic :: String -magic = "GHCJSOBJ" - --- | Serialized unit indexes and their exported symbols --- (the first unit is module-global) -type Index = [IndexEntry] -data IndexEntry = IndexEntry - { idxSymbols :: ![FastString] -- ^ Symbols exported by a unit - , idxOffset :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file - } - - --------------------------------------------------------------------------------- --- Essential oeprations on Objects --------------------------------------------------------------------------------- - --- | Given a handle to a Binary payload, add the module, 'mod_name', its --- dependencies, 'deps', and its linkable units to the payload. -putObject - :: BinHandle - -> ModuleName -- ^ module - -> Deps -- ^ dependencies - -> [ObjUnit] -- ^ linkable units and their symbols - -> IO () -putObject bh mod_name deps os = do - forM_ magic (putByte bh . fromIntegral . ord) - put_ bh (show hiVersion) - - -- we store the module name as a String because we don't want to have to - -- decode the FastString table just to decode it when we're looking for an - -- object in an archive. - put_ bh (moduleNameString mod_name) - - (bh_fs, _bin_dict, put_dict) <- initFSTable bh - - forwardPut_ bh (const put_dict) $ do - put_ bh_fs deps - - -- forward put the index - forwardPut_ bh_fs (put_ bh_fs) $ do - idx <- forM os $ \o -> do - p <- tellBin bh_fs - -- write units without their symbols - putObjUnit bh_fs o - -- return symbols and offset to store in the index - pure (oiSymbols o,p) - pure idx - --- | Test if the object file is a JS object -isJsObjectFile :: FilePath -> IO Bool -isJsObjectFile fp = do - let !n = length magic - withBinaryFile fp ReadMode $ \hdl -> do - allocaArray n $ \ptr -> do - n' <- hGetBuf hdl ptr n - if (n' /= n) - then pure False - else checkMagic (peekElemOff ptr) - --- | Check magic -checkMagic :: (Int -> IO Word8) -> IO Bool -checkMagic get_byte = do - let go_magic !i = \case - [] -> pure True - (e:es) -> get_byte i >>= \case - c | fromIntegral (ord e) == c -> go_magic (i+1) es - | otherwise -> pure False - go_magic 0 magic - --- | Parse object magic -getCheckMagic :: BinHandle -> IO Bool -getCheckMagic bh = checkMagic (const (getByte bh)) - --- | Parse object header -getObjectHeader :: BinHandle -> IO (Either String ModuleName) -getObjectHeader bh = do - is_magic <- getCheckMagic bh - case is_magic of - False -> pure (Left "invalid magic header") - True -> do - is_correct_version <- ((== hiVersion) . read) <$> get bh - case is_correct_version of - False -> pure (Left "invalid header version") - True -> do - mod_name <- get bh - pure (Right (mkModuleName (mod_name))) - - --- | Parse object body. Must be called after a sucessful getObjectHeader -getObjectBody :: BinHandle -> ModuleName -> IO Object -getObjectBody bh0 mod_name = do - -- Read the string table - dict <- forwardGet bh0 (getDictionary bh0) - let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict } - - deps <- get bh - idx <- forwardGet bh (get bh) - payload_pos <- tellBin bh - - pure $ Object - { objModuleName = mod_name - , objHandle = bh - , objPayloadOffset = payload_pos - , objDeps = deps - , objIndex = idx - } - --- | Parse object -getObject :: BinHandle -> IO (Maybe Object) -getObject bh = do - getObjectHeader bh >>= \case - Left _err -> pure Nothing - Right mod_name -> Just <$> getObjectBody bh mod_name - --- | Read object from file --- --- The object is still in memory after this (see objHandle). -readObject :: FilePath -> IO (Maybe Object) -readObject file = do - bh <- readBinMem file - getObject bh - --- | Reads only the part necessary to get the dependencies -readObjectDeps :: FilePath -> IO (Maybe Deps) -readObjectDeps file = do - bh <- readBinMem file - getObject bh >>= \case - Just obj -> pure $! Just $! objDeps obj - Nothing -> pure Nothing - --- | Get units in the object file, using the given filtering function -getObjectUnits :: Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] -getObjectUnits obj pred = mapMaybeM read_entry (zip (objIndex obj) [0..]) - where - bh = objHandle obj - read_entry (e@(IndexEntry syms offset),i) - | pred i e = do - seekBin bh offset - Just <$> getObjUnit syms bh - | otherwise = pure Nothing - --- | Read units in the object file, using the given filtering function -readObjectUnits :: FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] -readObjectUnits file pred = do - readObject file >>= \case - Nothing -> pure [] - Just obj -> getObjectUnits obj pred - - --------------------------------------------------------------------------------- --- Helper functions --------------------------------------------------------------------------------- - -putEnum :: Enum a => BinHandle -> a -> IO () -putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n) - | otherwise = put_ bh n - where n = fromIntegral $ fromEnum x :: Word16 - -getEnum :: Enum a => BinHandle -> IO a -getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16) - --- | Helper to convert Int to Int32 -toI32 :: Int -> Int32 -toI32 = fromIntegral - --- | Helper to convert Int32 to Int -fromI32 :: Int32 -> Int -fromI32 = fromIntegral - - --------------------------------------------------------------------------------- --- Binary Instances --------------------------------------------------------------------------------- - -instance Binary IndexEntry where - put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b - get bh = IndexEntry <$> get bh <*> get bh - -instance Binary Deps where - put_ bh (Deps m r e b) = do - put_ bh m - put_ bh (map toI32 $ IS.toList r) - put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e) - put_ bh (elems b) - get bh = Deps <$> get bh - <*> (IS.fromList . map fromI32 <$> get bh) - <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh) - <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh) - -instance Binary BlockDeps where - put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd - get bh = BlockDeps <$> get bh <*> get bh - -instance Binary ForeignJSRef where - put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) = - put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty - get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh - -instance Binary ExpFun where - put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res - get bh = ExpFun <$> get bh <*> get bh <*> get bh - -instance Binary JStat where - put_ bh (DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e - put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e - put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 - put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock" - put_ bh (LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml - get bh = getByte bh >>= \case - 1 -> DeclStat <$> get bh <*> get bh - 2 -> ReturnStat <$> get bh - 3 -> IfStat <$> get bh <*> get bh <*> get bh - 4 -> WhileStat <$> get bh <*> get bh <*> get bh - 5 -> ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> BlockStat <$> get bh - 9 -> ApplStat <$> get bh <*> get bh - 10 -> UOpStat <$> get bh <*> get bh - 11 -> AssignStat <$> get bh <*> get bh - 12 -> LabelStat <$> get bh <*> get bh - 13 -> BreakStat <$> get bh - 14 -> ContinueStat <$> get bh - n -> error ("Binary get bh JStat: invalid tag: " ++ show n) - -instance Binary JExpr where - put_ bh (ValExpr v) = putByte bh 1 >> put_ bh v - put_ bh (SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i - put_ bh (IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 - put_ bh (InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 - put_ bh (UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e - put_ bh (IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 - put_ bh (ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es - put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr" - get bh = getByte bh >>= \case - 1 -> ValExpr <$> get bh - 2 -> SelExpr <$> get bh <*> get bh - 3 -> IdxExpr <$> get bh <*> get bh - 4 -> InfixExpr <$> get bh <*> get bh <*> get bh - 5 -> UOpExpr <$> get bh <*> get bh - 6 -> IfExpr <$> get bh <*> get bh <*> get bh - 7 -> ApplExpr <$> get bh <*> get bh - n -> error ("Binary get bh JExpr: invalid tag: " ++ show n) - -instance Binary JVal where - put_ bh (JVar i) = putByte bh 1 >> put_ bh i - put_ bh (JList es) = putByte bh 2 >> put_ bh es - put_ bh (JDouble d) = putByte bh 3 >> put_ bh d - put_ bh (JInt i) = putByte bh 4 >> put_ bh i - put_ bh (JStr xs) = putByte bh 5 >> put_ bh xs - put_ bh (JRegEx xs) = putByte bh 6 >> put_ bh xs - put_ bh (JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m) - put_ bh (JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s - put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal" - get bh = getByte bh >>= \case - 1 -> JVar <$> get bh - 2 -> JList <$> get bh - 3 -> JDouble <$> get bh - 4 -> JInt <$> get bh - 5 -> JStr <$> get bh - 6 -> JRegEx <$> get bh - 7 -> JHash . listToUniqMap <$> get bh - 8 -> JFunc <$> get bh <*> get bh - n -> error ("Binary get bh JVal: invalid tag: " ++ show n) - -instance Binary Ident where - put_ bh (TxtI xs) = put_ bh xs - get bh = TxtI <$> get bh - --- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this -instance Binary SaneDouble where - put_ bh (SaneDouble d) - | isNaN d = putByte bh 1 - | isInfinite d && d > 0 = putByte bh 2 - | isInfinite d && d < 0 = putByte bh 3 - | isNegativeZero d = putByte bh 4 - | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) - get bh = getByte bh >>= \case - 1 -> pure $ SaneDouble (0 / 0) - 2 -> pure $ SaneDouble (1 / 0) - 3 -> pure $ SaneDouble ((-1) / 0) - 4 -> pure $ SaneDouble (-0) - 5 -> SaneDouble . castWord64ToDouble <$> get bh - n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) - -instance Binary ClosureInfo where - put_ bh (ClosureInfo v regs name layo typ static) = do - put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static - get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh - -instance Binary JSFFIType where - put_ bh = putEnum bh - get bh = getEnum bh - -instance Binary VarType where - put_ bh = putEnum bh - get bh = getEnum bh - -instance Binary CIRegs where - put_ bh CIRegsUnknown = putByte bh 1 - put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types - get bh = getByte bh >>= \case - 1 -> pure CIRegsUnknown - 2 -> CIRegs <$> get bh <*> get bh - n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) - -instance Binary JOp where - put_ bh = putEnum bh - get bh = getEnum bh - -instance Binary JUOp where - put_ bh = putEnum bh - get bh = getEnum bh - --- 16 bit sizes should be enough... -instance Binary CILayout where - put_ bh CILayoutVariable = putByte bh 1 - put_ bh (CILayoutUnknown size) = putByte bh 2 >> put_ bh size - put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types - get bh = getByte bh >>= \case - 1 -> pure CILayoutVariable - 2 -> CILayoutUnknown <$> get bh - 3 -> CILayoutFixed <$> get bh <*> get bh - n -> error ("Binary get bh CILayout: invalid tag: " ++ show n) - -instance Binary CIStatic where - put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs - get bh = getByte bh >>= \case - 1 -> CIStaticRefs <$> get bh - n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n) - -instance Binary CIType where - put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs - put_ bh CIThunk = putByte bh 2 - put_ bh (CICon conTag) = putByte bh 3 >> put_ bh conTag - put_ bh CIPap = putByte bh 4 - put_ bh CIBlackhole = putByte bh 5 - put_ bh CIStackFrame = putByte bh 6 - get bh = getByte bh >>= \case - 1 -> CIFun <$> get bh <*> get bh - 2 -> pure CIThunk - 3 -> CICon <$> get bh - 4 -> pure CIPap - 5 -> pure CIBlackhole - 6 -> pure CIStackFrame - n -> error ("Binary get bh CIType: invalid tag: " ++ show n) - -instance Binary ExportedFun where - put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb - get bh = ExportedFun <$> get bh <*> get bh - -instance Binary StaticInfo where - put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc - get bh = StaticInfo <$> get bh <*> get bh <*> get bh - -instance Binary StaticVal where - put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args - put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t - put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u - put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args - put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t - get bh = getByte bh >>= \case - 1 -> StaticFun <$> get bh <*> get bh - 2 -> StaticThunk <$> get bh - 3 -> StaticUnboxed <$> get bh - 4 -> StaticData <$> get bh <*> get bh - 5 -> StaticList <$> get bh <*> get bh - n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) - -instance Binary StaticUnboxed where - put_ bh (StaticUnboxedBool b) = putByte bh 1 >> put_ bh b - put_ bh (StaticUnboxedInt i) = putByte bh 2 >> put_ bh i - put_ bh (StaticUnboxedDouble d) = putByte bh 3 >> put_ bh d - put_ bh (StaticUnboxedString str) = putByte bh 4 >> put_ bh str - put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str - get bh = getByte bh >>= \case - 1 -> StaticUnboxedBool <$> get bh - 2 -> StaticUnboxedInt <$> get bh - 3 -> StaticUnboxedDouble <$> get bh - 4 -> StaticUnboxedString <$> get bh - 5 -> StaticUnboxedStringOffset <$> get bh - n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n) - -instance Binary StaticArg where - put_ bh (StaticObjArg i) = putByte bh 1 >> put_ bh i - put_ bh (StaticLitArg p) = putByte bh 2 >> put_ bh p - put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args - get bh = getByte bh >>= \case - 1 -> StaticObjArg <$> get bh - 2 -> StaticLitArg <$> get bh - 3 -> StaticConArg <$> get bh <*> get bh - n -> error ("Binary get bh StaticArg: invalid tag " ++ show n) - -instance Binary StaticLit where - put_ bh (BoolLit b) = putByte bh 1 >> put_ bh b - put_ bh (IntLit i) = putByte bh 2 >> put_ bh i - put_ bh NullLit = putByte bh 3 - put_ bh (DoubleLit d) = putByte bh 4 >> put_ bh d - put_ bh (StringLit t) = putByte bh 5 >> put_ bh t - put_ bh (BinLit b) = putByte bh 6 >> put_ bh b - put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t - get bh = getByte bh >>= \case - 1 -> BoolLit <$> get bh - 2 -> IntLit <$> get bh - 3 -> pure NullLit - 4 -> DoubleLit <$> get bh - 5 -> StringLit <$> get bh - 6 -> BinLit <$> get bh - 7 -> LabelLit <$> get bh <*> get bh - n -> error ("Binary get bh StaticLit: invalid tag " ++ show n) diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs --- a/compiler/GHC/StgToJS/Prim.hs +++ b/compiler/GHC/StgToJS/Prim.hs @@ -13,7 +13,7 @@ import GHC.Prelude -import GHC.JS.Syntax hiding (JUOp (..)) +import GHC.JS.Unsat.Syntax hiding (JUOp (..)) import GHC.JS.Make import GHC.StgToJS.Heap @@ -56,9 +56,12 @@ ------------------------------ Int ---------------------------------------------- +-- N.B. See Note [StgToJS design] in GHC.StgToJS for details on +-- number representation. + IntAddOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Add x y) IntSubOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Sub x y) - IntMulOp -> \[r] [x,y] -> PrimInline $ r |= app "h$mulInt32" [x, y] + IntMulOp -> \[r] [x,y] -> PrimInline $ r |= app "Math.imul" [x, y] IntMul2Op -> \[c,hr,lr] [x,y] -> PrimInline $ appT [c,hr,lr] "h$hs_timesInt2" [x, y] IntMulMayOfloOp -> \[r] [x,y] -> PrimInline $ jVar \tmp -> mconcat [ tmp |= Mul x y @@ -373,7 +376,7 @@ ] WordAdd2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$wordAdd2" [x,y] WordSubOp -> \ [r] [x,y] -> PrimInline $ r |= toU32 (Sub x y) - WordMulOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$mulWord32" [x, y] + WordMulOp -> \ [r] [x,y] -> PrimInline $ r |= toU32 (app "Math.imul" [x, y]) WordMul2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$mul2Word32" [x,y] WordQuotOp -> \ [q] [x,y] -> PrimInline $ q |= app "h$quotWord32" [x,y] WordRemOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$remWord32" [x,y] @@ -488,6 +491,11 @@ DoubleDecode_2IntOp -> \[s,h,l,e] [x] -> PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x] DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d] + DoubleFMAdd -> unhandledPrimop op + DoubleFMSub -> unhandledPrimop op + DoubleFNMAdd -> unhandledPrimop op + DoubleFNMSub -> unhandledPrimop op + ------------------------------ Float -------------------------------------------- FloatGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) @@ -524,6 +532,11 @@ FloatToDoubleOp -> \[r] [x] -> PrimInline $ r |= x FloatDecode_IntOp -> \[s,e] [x] -> PrimInline $ appT [s,e] "h$decodeFloatInt" [x] + FloatFMAdd -> unhandledPrimop op + FloatFMSub -> unhandledPrimop op + FloatFNMAdd -> unhandledPrimop op + FloatFNMSub -> unhandledPrimop op + ------------------------------ Arrays ------------------------------------------- NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] @@ -704,15 +717,19 @@ CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] + SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v @@ -797,6 +814,8 @@ AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f] AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f] + AtomicSwapMutVarOp -> \[r] [mv,v] -> PrimInline $ mconcat + [ r |= mv .^ "val", mv .^ "val" |= v ] CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o) (mconcat [status |= zero_, r |= n, mv .^ "val" |= n]) (mconcat [status |= one_ , r |= mv .^ "val"]) diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs deleted file mode 100644 --- a/compiler/GHC/StgToJS/Printer.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Printer --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Stability : experimental --- --- Custom prettyprinter for JS AST uses the JS PPr module for most of --- the work --- --- ------------------------------------------------------------------------------ -module GHC.StgToJS.Printer - ( pretty - , ghcjsRenderJs - , prettyBlock - ) -where - -import GHC.Prelude -import GHC.Int -import GHC.Exts - -import GHC.JS.Syntax -import GHC.JS.Ppr - -import GHC.Utils.Ppr as PP -import GHC.Data.FastString -import GHC.Types.Unique.Map - -import Data.List (sortOn) -import Data.Char (isAlpha,isDigit,ord) -import qualified Data.ByteString.Short as SBS - -pretty :: JStat -> Doc -pretty = jsToDocR ghcjsRenderJs - -ghcjsRenderJs :: RenderJs -ghcjsRenderJs = defaultRenderJs - { renderJsV = ghcjsRenderJsV - , renderJsS = ghcjsRenderJsS - , renderJsI = ghcjsRenderJsI - } - -hdd :: SBS.ShortByteString -hdd = SBS.pack (map (fromIntegral . ord) "h$$") - -ghcjsRenderJsI :: RenderJs -> Ident -> Doc -ghcjsRenderJsI _ (TxtI fs) - -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by - -- name in user code, only in compiled code. Hence we can rename them if we do - -- it consistently in all the linked code. - -- - -- These symbols are usually very large because their name includes the - -- unit-id, the module name, and some unique number. So we rename these - -- symbols with a much shorter globally unique number. - -- - -- Here we reuse their FastString unique for this purpose! Note that it only - -- works if we pretty-print all the JS code linked together at once, which we - -- currently do. GHCJS used to maintain a CompactorState to support - -- incremental linking: it contained the mapping between original symbols and - -- their renaming. - | hdd `SBS.isPrefixOf` fastStringToShortByteString fs - , u <- uniqueOfFS fs - = text "h$$" <> hexDoc (fromIntegral u) - | otherwise - = ftext fs - --- | Render as an hexadecimal number in reversed order (because it's faster and we --- don't care about the actual value). -hexDoc :: Word -> Doc -hexDoc 0 = char '0' -hexDoc v = text $ go v - where - sym (I# i) = C# (indexCharOffAddr# chars i) - chars = "0123456789abcdef"# - go = \case - 0 -> [] - n -> sym (fromIntegral (n .&. 0x0F)) - : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) - : go (n `shiftR` 8) - - - - --- attempt to resugar some of the common constructs -ghcjsRenderJsS :: RenderJs -> JStat -> Doc -ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s - --- don't quote keys in our object literals, so closure compiler works -ghcjsRenderJsV :: RenderJs -> JVal -> Doc -ghcjsRenderJsV r (JHash m) - | isNullUniqMap m = text "{}" - | otherwise = braceNest . PP.fsep . punctuate comma . - map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y) - -- nonDetEltsUniqMap doesn't introduce non-determinism here because - -- we sort the elements lexically - . sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m - where - quoteIfRequired :: FastString -> Doc - quoteIfRequired x - | isUnquotedKey x' = text x' - | otherwise = PP.squotes (text x') - where x' = unpackFS x - - isUnquotedKey :: String -> Bool - isUnquotedKey x | null x = False - | all isDigit x = True - | otherwise = validFirstIdent (head x) - && all validOtherIdent (tail x) - - - validFirstIdent c = c == '_' || c == '$' || isAlpha c - validOtherIdent c = isAlpha c || isDigit c -ghcjsRenderJsV r v = renderJsV defaultRenderJs r v - -prettyBlock :: RenderJs -> [JStat] -> Doc -prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) - --- recognize common patterns in a block and convert them to more idiomatic/concise javascript -prettyBlock' :: RenderJs -> [JStat] -> [Doc] --- return/... -prettyBlock' r ( x@(ReturnStat _) - : xs - ) - | not (null xs) - = prettyBlock' r [x] --- declare/assign -prettyBlock' r ( (DeclStat i Nothing) - : (AssignStat (ValExpr (JVar i')) v) - : xs - ) - | i == i' - = prettyBlock' r (DeclStat i (Just v) : xs) - --- resugar for loops with/without var declaration -prettyBlock' r ( (DeclStat i (Just v0)) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs - --- global function (does not preserve semantics but works for GHCJS) -prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) - : xs - ) - = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) - (jsToDocR r b) - ) : prettyBlock' r xs --- modify/assign operators -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs - - -prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs -prettyBlock' _ [] = [] - --- build the for block -mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc -mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) - (jsToDocR r $ BlockStat sb) - where - c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 - | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 - forCond = parens $ hcat $ interSemi - [ c0 - , jsToDocR r p - , parens (jsToDocR r s1) - ] - --- check if a statement is suitable to be converted to something in the for(;;x) position -isForUpdStat :: JStat -> Bool -isForUpdStat UOpStat {} = True -isForUpdStat AssignStat {} = True -isForUpdStat ApplStat {} = True -isForUpdStat _ = False - -interSemi :: [Doc] -> [Doc] -interSemi [] = [PP.empty] -interSemi [s] = [s] -interSemi (x:xs) = x <> text ";" : interSemi xs - -addSemi :: Doc -> Doc -addSemi x = x <> text ";" diff --git a/compiler/GHC/StgToJS/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs --- a/compiler/GHC/StgToJS/Profiling.hs +++ b/compiler/GHC/StgToJS/Profiling.hs @@ -26,7 +26,7 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Regs diff --git a/compiler/GHC/StgToJS/Regs.hs b/compiler/GHC/StgToJS/Regs.hs --- a/compiler/GHC/StgToJS/Regs.hs +++ b/compiler/GHC/StgToJS/Regs.hs @@ -21,7 +21,7 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.Data.FastString diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs --- a/compiler/GHC/StgToJS/Rts/Rts.hs +++ b/compiler/GHC/StgToJS/Rts/Rts.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -O0 #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} ----------------------------------------------------------------------------- -- | @@ -23,18 +23,23 @@ -- ----------------------------------------------------------------------------- -module GHC.StgToJS.Rts.Rts where +module GHC.StgToJS.Rts.Rts + ( rts + , assignRegs + ) +where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure import GHC.StgToJS.Heap -import GHC.StgToJS.Printer import GHC.StgToJS.Profiling import GHC.StgToJS.Regs import GHC.StgToJS.Types @@ -51,8 +56,8 @@ -- | The garbageCollector resets registers and result variables. garbageCollector :: JStat garbageCollector = - mconcat [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound]) - , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound]) + mconcat [ jFun (TxtI "h$resetRegisters") (mconcat $ map resetRegister [minBound..maxBound]) + , jFun (TxtI "h$resetResultVars") (mconcat $ map resetResultVar [minBound..maxBound]) ] -- | Reset the register 'r' in JS Land. Note that this "resets" by setting the @@ -81,36 +86,8 @@ -- JIT can optimize better. closureConstructors :: StgToJSConfig -> JStat closureConstructors s = BlockStat - [ declClsConstr "h$c" ["f"] $ Closure - { clEntry = var "f" - , clField1 = null_ - , clField2 = null_ - , clMeta = 0 - , clCC = ccVal - } - , declClsConstr "h$c0" ["f"] $ Closure - { clEntry = var "f" - , clField1 = null_ - , clField2 = null_ - , clMeta = 0 - , clCC = ccVal - } - , declClsConstr "h$c1" ["f", "x1"] $ Closure - { clEntry = var "f" - , clField1 = var "x1" - , clField2 = null_ - , clMeta = 0 - , clCC = ccVal - } - , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure - { clEntry = var "f" - , clField1 = var "x1" - , clField2 = var "x2" - , clMeta = 0 - , clCC = ccVal - } - , mconcat (map mkClosureCon [3..24]) - , mconcat (map mkDataFill [1..24]) + [ mconcat (map mkClosureCon (Nothing : map Just [0..jsClosureCount])) + , mconcat (map mkDataFill [1..jsClosureCount]) ] where prof = csProf s @@ -118,19 +95,8 @@ -- the cc argument happens to be named just like the cc field... | prof = ([TxtI closureCC_], Just (var closureCC_)) | otherwise = ([], Nothing) - addCCArg as = map TxtI as ++ ccArg addCCArg' as = as ++ ccArg - declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as) - ( jVar $ \x -> - [ checkC - , x |= newClosure cl - , notifyAlloc x - , traceAlloc x - , returnS x - ] - )) - traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x] | otherwise = mempty @@ -172,41 +138,35 @@ | otherwise = mempty - mkClosureCon :: Int -> JStat - mkClosureCon n = funName ||= toJExpr fun + mkClosureCon :: Maybe Int -> JStat + mkClosureCon n0 = jFunction funName args funBod where - funName = TxtI $ mkFastString ("h$c" ++ show n) + n | Just n' <- n0 = n' + | Nothing <- n0 = 0 + funName | Just n' <- n0 = TxtI $ clsName n' + | Nothing <- n0 = TxtI $ mkFastString "h$c" -- args are: f x1 x2 .. xn [cc] - args = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n]) - fun = JFunc args funBod + args = TxtI "f" : addCCArg' (map varName [1..n]) -- x1 goes into closureField1. All the other args are bundled into an -- object in closureField2: { d1 = x2, d2 = x3, ... } -- - extra_args = ValExpr . JHash . listToUniqMap $ zip - (map (mkFastString . ('d':) . show) [(1::Int)..]) - (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n]) + vars = map (toJExpr . varName) [1..n] funBod = jVar $ \x -> [ checkC - , x |= newClosure Closure - { clEntry = var "f" - , clField1 = var "x1" - , clField2 = extra_args - , clMeta = 0 - , clCC = ccVal - } + , x |= newClosure (mkClosure (var "f") vars 0 ccVal) , notifyAlloc x , traceAlloc x , returnS x ] mkDataFill :: Int -> JStat - mkDataFill n = funName ||= toJExpr fun + mkDataFill n = jFunction funName (map TxtI ds) body where - funName = TxtI $ mkFastString ("h$d" ++ show n) - ds = map (mkFastString . ('d':) . show) [(1::Int)..n] + funName = TxtI $ dataName n + ds = map dataFieldName [1..n] extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + body = (checkD <> returnS extra_args) -- | JS Payload to perform stack manipulation in the RTS stackManip :: JStat @@ -215,11 +175,11 @@ where mkPush :: Int -> JStat mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) - as = map (TxtI . mkFastString . ('x':) . show) [1..n] - fun = JFunc as ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) - [1..] as)) - in funName ||= toJExpr fun + as = map varName [1..n] + body = ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in jFunction funName as body -- partial pushes, based on bitmap, increases Sp by highest bit mkPpush :: Integer -> JStat @@ -228,12 +188,11 @@ bits = bitsIdx sig n = length bits h = last bits - args = map (TxtI . mkFastString . ('x':) . show) [1..n] - fun = JFunc args $ - mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in funName ||= toJExpr fun + args = map varName [1..n] + body = mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in jFunction funName args body bitsIdx :: Integer -> [Int] bitsIdx n | n < 0 = error "bitsIdx: negative" @@ -274,8 +233,8 @@ -- | JS payload to define getters and setters on the registers. regGettersSetters :: JStat regGettersSetters = - mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty) - , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty) + mconcat [ jFun (TxtI "h$getReg") (\n -> SwitchStat n getRegCases mempty) + , jFun (TxtI "h$setReg") (\n v -> SwitchStat n (setRegCases v) mempty) ] where getRegCases = @@ -288,12 +247,12 @@ loadRegs = mconcat $ map mkLoad [1..32] where mkLoad :: Int -> JStat - mkLoad n = let args = map (TxtI . mkFastString . ("x"++) . show) [1..n] - assign = zipWith (\a r -> toJExpr r |= toJExpr a) - args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - fun = JFunc args (mconcat assign) - in fname ||= toJExpr fun + mkLoad n = let args = map varName [1..n] + body = mconcat $ + zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + in jFunction fname args body -- | Assign registers R1 ... Rn in descending order, that is assign Rn first. -- This function uses the 'assignRegs'' array to construct functions which set @@ -333,17 +292,16 @@ mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE" in s ||= toJExpr c closureTypeName :: JStat - closureTypeName = - TxtI "h$closureTypeName" ||= jLam (\c -> - mconcat (map (ifCT c) [minBound..maxBound]) - <> returnS (jString "InvalidClosureType")) + closureTypeName = jFun (TxtI "h$closureTypeName") \c -> + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType") ifCT :: JExpr -> ClosureType -> JStat ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. rtsDecls :: JStat -rtsDecls = jsSaturate (Just "h$RTSD") $ +rtsDecls = mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread , TxtI "h$sp" ||= 0 -- stack pointer for the current thread @@ -356,17 +314,12 @@ , declRegs , declRets] --- | print the embedded RTS to a String -rtsText :: StgToJSConfig -> String -rtsText = show . pretty . rts - --- | print the RTS declarations to a String. -rtsDeclsText :: String -rtsDeclsText = show . pretty $ rtsDecls - --- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat -rts = jsSaturate (Just "h$RTS") . rts' +-- | Generated RTS code +rts :: StgToJSConfig -> Sat.JStat +rts cfg = jsOptimize $ satJStat (Just "h$RTS") $ mconcat + [ rtsDecls + , rts' cfg + ] -- | JS Payload which defines the embedded RTS. rts' :: StgToJSConfig -> JStat @@ -387,11 +340,10 @@ , TxtI "h$vt_double" ||= toJExpr IntV , TxtI "h$vt_long" ||= toJExpr LongV , TxtI "h$vt_addr" ||= toJExpr AddrV - , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV , TxtI "h$vt_obj" ||= toJExpr ObjV , TxtI "h$vt_arr" ||= toJExpr ArrV - , TxtI "h$bh" ||= jLam (bhStats s True) - , TxtI "h$bh_lne" ||= jLam (\x frameSize -> bhLneStats s x frameSize) + , jFun (TxtI "h$bh") (bhStats s True) + , jFun (TxtI "h$bh_lne") (\x frameSize -> bhLneStats s x frameSize) , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty) (appS "throw" [jString "oops: entered black hole"]) , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty) diff --git a/compiler/GHC/StgToJS/Rts/Types.hs b/compiler/GHC/StgToJS/Rts/Types.hs --- a/compiler/GHC/StgToJS/Rts/Types.hs +++ b/compiler/GHC/StgToJS/Rts/Types.hs @@ -22,7 +22,7 @@ import GHC.Prelude import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.StgToJS.Regs import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/Sinker.hs b/compiler/GHC/StgToJS/Sinker.hs --- a/compiler/GHC/StgToJS/Sinker.hs +++ b/compiler/GHC/StgToJS/Sinker.hs @@ -15,7 +15,7 @@ import GHC.Types.Literal import GHC.Data.Graph.Directed -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import Data.Char import Data.Either @@ -64,11 +64,11 @@ alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)] alwaysSinkable (StgRec {}) = [] alwaysSinkable (StgNonRec b rhs) = case rhs of - StgRhsClosure _ _ _ _ e@(StgLit l) + StgRhsClosure _ _ _ _ e@(StgLit l) _ | isSmallSinkableLit l , isLocal b -> [(b,e)] - StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] + StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ | isSmallSinkableLit l , isLocal b , isUnboxableCon dc @@ -88,9 +88,9 @@ , isLocal b = [(b,e)] where getSinkable = \case - StgRhsCon _ccs dc cnum _ticks args -> Just (StgConApp dc cnum args []) - StgRhsClosure _ _ _ _ e@(StgLit{}) -> Just e - _ -> Nothing + StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args []) + StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e + _ -> Nothing onceSinkable _ _ = [] -- | collect all idents used only once in an argument at the top level @@ -115,8 +115,8 @@ collectArgsTopRhs :: CgStgRhs -> [Id] collectArgsTopRhs = \case - StgRhsCon _ccs _dc _mu _ticks args -> concatMap collectArgsA args - StgRhsClosure {} -> [] + StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args + StgRhsClosure {} -> [] -- | fold over all Id in StgArg in the AST collectArgs :: CgStgBinding -> [Id] @@ -126,8 +126,8 @@ collectArgsR :: CgStgRhs -> [Id] collectArgsR = \case - StgRhsClosure _x0 _x1 _x2 _x3 e -> collectArgsE e - StgRhsCon _ccs _con _mu _ticks args -> concatMap collectArgsA args + StgRhsClosure _x0 _x1 _x2 _x3 e _typ -> collectArgsE e + StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args collectArgsAlt :: CgStgAlt -> [Id] collectArgsAlt alt = collectArgsE (alt_rhs alt) @@ -171,7 +171,7 @@ keys = mkUniqSet (map node_key vs) getV e@(StgNonRec b _) = DigraphNode e b [] getV _ = error "topSortDecls: getV, unexpected binding" - collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args)) = + collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) = [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ] collectDeps _ = [] g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr) diff --git a/compiler/GHC/StgToJS/Stack.hs b/compiler/GHC/StgToJS/Stack.hs --- a/compiler/GHC/StgToJS/Stack.hs +++ b/compiler/GHC/StgToJS/Stack.hs @@ -66,7 +66,7 @@ import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/StaticPtr.hs b/compiler/GHC/StgToJS/StaticPtr.hs --- a/compiler/GHC/StgToJS/StaticPtr.hs +++ b/compiler/GHC/StgToJS/StaticPtr.hs @@ -10,7 +10,7 @@ import GHC.Fingerprint.Type import GHC.Types.Literal -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/StgUtils.hs b/compiler/GHC/StgToJS/StgUtils.hs deleted file mode 100644 --- a/compiler/GHC/StgToJS/StgUtils.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module GHC.StgToJS.StgUtils - ( bindingRefs - , hasExport - , collectTopIds - , collectIds - , removeTick - , isUpdatableRhs - , isInlineExpr - , exprRefs - -- * Live vars - , LiveVars - , liveVars - , liveStatic - , stgRhsLive - , stgExprLive - , stgTopBindLive - , stgLetNoEscapeLive - , stgLneLiveExpr - , stgLneLive - , stgLneLive' - ) -where - -import GHC.Prelude - -import GHC.Stg.Syntax -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.TyCon - -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Types.Unique -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.ForeignCall -import GHC.Types.TyThing -import GHC.Types.Name -import GHC.Types.Var.Set - -import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) -import GHC.Utils.Misc (seqList) -import GHC.Utils.Panic - -import qualified Data.Foldable as F -import qualified Data.Set as S -import qualified Data.List as L -import Data.Set (Set) -import Data.Monoid - -s :: a -> Set a -s = S.singleton - -l :: (a -> Set Id) -> [a] -> Set Id -l = F.foldMap - --- | collect Ids that this binding refers to --- (does not include the bindees themselves) --- first argument is Id -> StgExpr map for unfloated arguments -bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id -bindingRefs u = \case - StgNonRec _ rhs -> rhsRefs u rhs - StgRec bs -> l (rhsRefs u . snd) bs - -rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id -rhsRefs u = \case - StgRhsClosure _ _ _ _ body -> exprRefs u body - StgRhsCon _ccs d _mu _ticks args -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args - -exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id -exprRefs u = \case - StgApp f args -> s f <> l (argRefs u) args - StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args - StgOpApp _ args _ -> l (argRefs u) args - StgLit {} -> mempty - StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) - StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr - StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr - StgTick _ expr -> exprRefs u expr - -altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id -altRefs u alt = exprRefs u (alt_rhs alt) - -argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id -argRefs u = \case - StgVarArg id - | Just e <- lookupUFM u id -> exprRefs u e - | otherwise -> s id - _ -> mempty - -hasExport :: CgStgBinding -> Bool -hasExport bnd = - case bnd of - StgNonRec b e -> isExportedBind b e - StgRec bs -> any (uncurry isExportedBind) bs - where - isExportedBind _i (StgRhsCon _cc con _ _ _) = - getUnique con == staticPtrDataConKey - isExportedBind _ _ = False - -collectTopIds :: CgStgBinding -> [Id] -collectTopIds (StgNonRec b _) = [b] -collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs - in seqList xs `seq` xs - -collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] -collectIds unfloated b = - let xs = map zapFragileIdInfo . - filter acceptId $ S.toList (bindingRefs unfloated b) - in seqList xs `seq` xs - where - acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] - -- the GHC.Prim module has no js source file - isForbidden i - | Just m <- nameModule_maybe (getName i) = m == gHC_PRIM - | otherwise = False - -removeTick :: CgStgExpr -> CgStgExpr -removeTick (StgTick _ e) = e -removeTick e = e - ------------------------------------------------------ --- Live vars --- --- TODO: should probably be moved into GHC.Stg.LiveVars - -type LiveVars = DVarSet - -liveStatic :: LiveVars -> LiveVars -liveStatic = filterDVarSet isGlobalId - -liveVars :: LiveVars -> LiveVars -liveVars = filterDVarSet (not . isGlobalId) - -stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)] -stgTopBindLive = \case - StgTopLifted b -> stgBindLive b - StgTopStringLit {} -> [] - -stgBindLive :: CgStgBinding -> [(Id, LiveVars)] -stgBindLive = \case - StgNonRec b rhs -> [(b, stgRhsLive rhs)] - StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs - -stgBindRhsLive :: CgStgBinding -> LiveVars -stgBindRhsLive b = - let (bs, ls) = unzip (stgBindLive b) - in delDVarSetList (unionDVarSets ls) bs - -stgRhsLive :: CgStgRhs -> LiveVars -stgRhsLive = \case - StgRhsClosure _ _ _ args e -> delDVarSetList (stgExprLive True e) args - StgRhsCon _ _ _ _ args -> unionDVarSets (map stgArgLive args) - -stgArgLive :: StgArg -> LiveVars -stgArgLive = \case - StgVarArg occ -> unitDVarSet occ - StgLitArg {} -> emptyDVarSet - -stgExprLive :: Bool -> CgStgExpr -> LiveVars -stgExprLive includeLHS = \case - StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) - StgLit {} -> emptyDVarSet - StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) - StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) - StgCase e b _at alts - | includeLHS -> el `unionDVarSet` delDVarSet al b - | otherwise -> delDVarSet al b - where - al = unionDVarSets (map stgAltLive alts) - el = stgExprLive True e - StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) - StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) - StgTick _ti e -> stgExprLive True e - -stgAltLive :: CgStgAlt -> LiveVars -stgAltLive alt = - delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) - -stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars -stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive" - -bindees :: CgStgBinding -> [Id] -bindees = \case - StgNonRec b _e -> [b] - StgRec bs -> map fst bs - -isUpdatableRhs :: CgStgRhs -> Bool -isUpdatableRhs (StgRhsClosure _ _ u _ _) = isUpdatable u -isUpdatableRhs _ = False - -stgLneLive' :: CgStgBinding -> [Id] -stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) - -stgLneLive :: CgStgBinding -> [Id] -stgLneLive (StgNonRec _b e) = stgLneLiveExpr e -stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs - -stgLneLiveExpr :: CgStgRhs -> [Id] -stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) --- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) --- stgLneLiveExpr StgRhsCon {} = [] - --- | returns True if the expression is definitely inline -isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool) -isInlineExpr v = \case - StgApp i args - -> (emptyUniqSet, isInlineApp v i args) - StgLit{} - -> (emptyUniqSet, True) - StgConApp{} - -> (emptyUniqSet, True) - StgOpApp (StgFCallOp f _) _ _ - -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) - StgOpApp (StgPrimOp op) _ _ - -> (emptyUniqSet, primOpIsReallyInline op) - StgOpApp (StgPrimCallOp _c) _ _ - -> (emptyUniqSet, True) - StgCase e b _ alts - ->let (_ve, ie) = isInlineExpr v e - v' = addOneToUniqSet v b - (vas, ias) = unzip $ map (isInlineExpr v') (fmap alt_rhs alts) - vr = L.foldl1' intersectUniqSets vas - in (vr, (ie || b `elementOfUniqSet` v) && and ias) - StgLet _ b e - -> isInlineExpr (inspectInlineBinding v b) e - StgLetNoEscape _ _b e - -> isInlineExpr v e - StgTick _ e - -> isInlineExpr v e - -inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id -inspectInlineBinding v = \case - StgNonRec i r -> inspectInlineRhs v i r - StgRec bs -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs - -inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id -inspectInlineRhs v i = \case - StgRhsCon{} -> addOneToUniqSet v i - StgRhsClosure _ _ ReEntrant _ _ -> addOneToUniqSet v i - _ -> v - -isInlineForeignCall :: ForeignCall -> Bool -isInlineForeignCall (CCall (CCallSpec _ cconv safety)) = - not (playInterruptible safety) && - not (cconv /= JavaScriptCallConv && playSafe safety) - -isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool -isInlineApp v i = \case - _ | isJoinId i -> False - [] -> isUnboxedTupleType (idType i) || - isStrictType (idType i) || - i `elementOfUniqSet` v - - [StgVarArg a] - | DataConWrapId dc <- idDetails i - , isNewTyCon (dataConTyCon dc) - , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a - -> True - _ -> False - diff --git a/compiler/GHC/StgToJS/Symbols.hs b/compiler/GHC/StgToJS/Symbols.hs --- a/compiler/GHC/StgToJS/Symbols.hs +++ b/compiler/GHC/StgToJS/Symbols.hs @@ -8,32 +8,23 @@ , mkFreshJsSymbol , mkRawSymbol , intBS - , word64BS ) where import GHC.Prelude import GHC.Data.FastString import GHC.Unit.Module -import GHC.Utils.Word64 (intToWord64) import Data.ByteString (ByteString) -import Data.Word (Word64) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as BSL -- | Hexadecimal representation of an int -- --- Used for the sub indices. -intBS :: Int -> ByteString -intBS = word64BS . intToWord64 - --- | Hexadecimal representation of a 64-bit word --- -- Used for uniques. We could use base-62 as GHC usually does but this is likely -- faster. -word64BS :: Word64 -> ByteString -word64BS = BSL.toStrict . BSB.toLazyByteString . BSB.word64Hex +intBS :: Int -> ByteString +intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral -- | Return z-encoded unit:module unitModuleStringZ :: Module -> ByteString diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs deleted file mode 100644 --- a/compiler/GHC/StgToJS/Types.hs +++ /dev/null @@ -1,431 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Types --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Josh Meredith --- Stability : experimental --- --- --- Module that holds the Types required for the StgToJS pass ------------------------------------------------------------------------------ - -module GHC.StgToJS.Types where - -import GHC.Prelude - -import GHC.JS.Syntax -import GHC.JS.Make -import GHC.JS.Ppr () - -import GHC.Stg.Syntax -import GHC.Core.TyCon - -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Var -import GHC.Types.ForeignCall - -import Control.Monad.Trans.State.Strict -import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$)) - -import GHC.Data.FastString -import GHC.Data.FastMutInt - -import GHC.Unit.Module - -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.ByteString as BS -import Data.Monoid -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Control.DeepSeq -import Data.Word - --- | A State monad over IO holding the generator state. -type G = StateT GenState IO - --- | The JS code generator state -data GenState = GenState - { gsSettings :: !StgToJSConfig -- ^ codegen settings, read-only - , gsModule :: !Module -- ^ current module - , gsId :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator - , gsIdents :: !IdCache -- ^ hash consing for identifiers from a Unique - , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments - , gsGroup :: GenGroupState -- ^ state for the current binding group - , gsGlobal :: [JStat] -- ^ global (per module) statements (gets included when anything else from the module is used) - } - --- | The JS code generator state relevant for the current binding group -data GenGroupState = GenGroupState - { ggsToplevelStats :: [JStat] -- ^ extra toplevel statements for the binding group - , ggsClosureInfo :: [ClosureInfo] -- ^ closure metadata (info tables) for the binding group - , ggsStatic :: [StaticInfo] -- ^ static (CAF) data in our binding group - , ggsStack :: [StackSlot] -- ^ stack info for the current expression - , ggsStackDepth :: Int -- ^ current stack depth - , ggsExtraDeps :: Set OtherSymb -- ^ extra dependencies for the linkable unit that contains this group - , ggsGlobalIdCache :: GlobalIdCache - , ggsForeignRefs :: [ForeignJSRef] - } - --- | The Configuration record for the StgToJS pass -data StgToJSConfig = StgToJSConfig - -- flags - { csInlinePush :: !Bool - , csInlineBlackhole :: !Bool - , csInlineLoadRegs :: !Bool - , csInlineEnter :: !Bool - , csInlineAlloc :: !Bool - , csTraceRts :: !Bool - , csAssertRts :: !Bool - , csBoundsCheck :: !Bool - , csDebugAlloc :: !Bool - , csTraceForeign :: !Bool - , csProf :: !Bool -- ^ Profiling enabled - , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions - -- settings - , csContext :: !SDocContext - } - --- | Information relevenat to code generation for closures. -data ClosureInfo = ClosureInfo - { ciVar :: Ident -- ^ object being infod - , ciRegs :: CIRegs -- ^ size of the payload (in number of JS values) - , ciName :: FastString -- ^ friendly name for printing - , ciLayout :: CILayout -- ^ heap/stack layout of the object - , ciType :: CIType -- ^ type of the object, with extra info where required - , ciStatic :: CIStatic -- ^ static references of this object - } - deriving stock (Eq, Show, Generic) - --- | Closure information, 'ClosureInfo', registers -data CIRegs - = CIRegsUnknown -- ^ A value witnessing a state of unknown registers - | CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start - , ciRegsTypes :: [VarType] -- ^ args - } - deriving stock (Eq, Ord, Show, Generic) - -instance NFData CIRegs - --- | Closure Information, 'ClosureInfo', layout -data CILayout - = CILayoutVariable -- ^ layout stored in object itself, first position from the start - | CILayoutUnknown -- ^ fixed size, but content unknown (for example stack apply frame) - { layoutSize :: !Int - } - | CILayoutFixed -- ^ whole layout known - { layoutSize :: !Int -- ^ closure size in array positions, including entry - , layout :: [VarType] -- ^ The set of sized Types to layout - } - deriving stock (Eq, Ord, Show, Generic) - -instance NFData CILayout - --- | The type of 'ClosureInfo' -data CIType - = CIFun { citArity :: !Int -- ^ function arity - , citRegs :: !Int -- ^ number of registers for the args - } - | CIThunk -- ^ The closure is a THUNK - | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor - | CIPap -- ^ The closure is a Partial Application - | CIBlackhole -- ^ The closure is a black hole - | CIStackFrame -- ^ The closure is a stack frame - deriving stock (Eq, Ord, Show, Generic) - -instance NFData CIType - --- | Static references that must be kept alive -newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] } - deriving stock (Eq, Generic) - deriving newtype (Semigroup, Monoid, Show) - --- | static refs: array = references, null = nothing to report --- note: only works after all top-level objects have been created -instance ToJExpr CIStatic where - toJExpr (CIStaticRefs []) = null_ -- [je| null |] - toJExpr (CIStaticRefs rs) = toJExpr (map TxtI rs) - --- | Free variable types -data VarType - = PtrV -- ^ pointer = reference to heap object (closure object) - | VoidV -- ^ no fields - | DoubleV -- ^ A Double: one field - | IntV -- ^ An Int (32bit because JS): one field - | LongV -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian) - | AddrV -- ^ a pointer not to the heap: two fields, array + index - | RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#) - | ObjV -- ^ some JS object, user supplied, be careful around these, can be anything - | ArrV -- ^ boxed array - deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) - -instance NFData VarType - -instance ToJExpr VarType where - toJExpr = toJExpr . fromEnum - --- | The type of identifiers. These determine the suffix of generated functions --- in JS Land. For example, the entry function for the 'Just' constructor is a --- 'IdConEntry' which compiles to: --- @ --- function h$baseZCGHCziMaybeziJust_con_e() { return h$rs() }; --- @ --- which just returns whatever the stack point is pointing to. Whereas the entry --- function to 'Just' is an 'IdEntry' and does the work. It compiles to: --- @ --- function h$baseZCGHCziMaybeziJust_e() { --- var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2; --- h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5); --- return h$rs(); --- }; --- @ --- Which loads some payload from register 2, and applies the Constructor Entry --- function for the Just to the payload, returns the result in register 1 and --- returns whatever is on top of the stack -data IdType - = IdPlain -- ^ A plain identifier for values, no suffix added - | IdEntry -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId' - | IdConEntry -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId' - deriving (Enum, Eq, Ord) - --- | Keys to differentiate Ident's in the ID Cache -data IdKey - = IdKey !Word64 !Int !IdType - deriving (Eq, Ord) - --- | Some other symbol -data OtherSymb - = OtherSymb !Module !FastString - deriving Eq - -instance Ord OtherSymb where - compare (OtherSymb m1 t1) (OtherSymb m2 t2) - = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2 - --- | The identifier cache indexed on 'IdKey' local to a module -newtype IdCache = IdCache (M.Map IdKey Ident) - --- | The global Identifier Cache -newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id)) - --- | A Stack Slot is either known or unknown. We avoid maybe here for more --- strictness. -data StackSlot - = SlotId !Id !Int - | SlotUnknown - deriving (Eq, Ord) - -data StaticInfo = StaticInfo - { siVar :: !FastString -- ^ global object - , siVal :: !StaticVal -- ^ static initialization - , siCC :: !(Maybe Ident) -- ^ optional CCS name - } deriving stock (Eq, Show, Typeable, Generic) - -data StaticVal - = StaticFun !FastString [StaticArg] - -- ^ heap object for function - | StaticThunk !(Maybe (FastString,[StaticArg])) - -- ^ heap object for CAF (field is Nothing when thunk is initialized in an - -- alternative way, like string thunks through h$str) - | StaticUnboxed !StaticUnboxed - -- ^ unboxed constructor (Bool, Int, Double etc) - | StaticData !FastString [StaticArg] - -- ^ regular datacon app - | StaticList [StaticArg] (Maybe FastString) - -- ^ list initializer (with optional tail) - deriving stock (Eq, Show, Generic) - -data StaticUnboxed - = StaticUnboxedBool !Bool - | StaticUnboxedInt !Integer - | StaticUnboxedDouble !SaneDouble - | StaticUnboxedString !BS.ByteString - | StaticUnboxedStringOffset !BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - -instance NFData StaticUnboxed - --- | Static Arguments. Static Arguments are things that are statically --- allocated, i.e., they exist at program startup. These are static heap objects --- or literals or things that have been floated to the top level binding by ghc. -data StaticArg - = StaticObjArg !FastString -- ^ reference to a heap object - | StaticLitArg !StaticLit -- ^ literal - | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor - deriving stock (Eq, Show, Generic) - -instance Outputable StaticArg where - ppr x = text (show x) - --- | A Static literal value -data StaticLit - = BoolLit !Bool - | IntLit !Integer - | NullLit - | DoubleLit !SaneDouble -- should we actually use double here? - | StringLit !FastString - | BinLit !BS.ByteString - | LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init) - deriving (Eq, Show, Generic) - -instance Outputable StaticLit where - ppr x = text (show x) - - -instance ToJExpr StaticLit where - toJExpr (BoolLit b) = toJExpr b - toJExpr (IntLit i) = toJExpr i - toJExpr NullLit = null_ - toJExpr (DoubleLit d) = toJExpr (unSaneDouble d) - toJExpr (StringLit t) = app (mkFastString "h$str") [toJExpr t] - toJExpr (BinLit b) = app (mkFastString "h$rstr") [toJExpr (map toInteger (BS.unpack b))] - toJExpr (LabelLit _isFun lbl) = var lbl - --- | A foreign reference to some JS code -data ForeignJSRef = ForeignJSRef - { foreignRefSrcSpan :: !FastString - , foreignRefPattern :: !FastString - , foreignRefSafety :: !Safety - , foreignRefCConv :: !CCallConv - , foreignRefArgs :: ![FastString] - , foreignRefResult :: !FastString - } deriving stock (Generic) - --- | data used to generate one ObjUnit in our object file -data LinkableUnit = LinkableUnit - { luObjUnit :: ObjUnit -- ^ serializable unit info - , luIdExports :: [Id] -- ^ exported names from haskell identifiers - , luOtherExports :: [FastString] -- ^ other exports - , luIdDeps :: [Id] -- ^ identifiers this unit depends on - , luPseudoIdDeps :: [Unique] -- ^ pseudo-id identifiers this unit depends on (fixme) - , luOtherDeps :: [OtherSymb] -- ^ symbols not from a haskell id that this unit depends on - , luRequired :: Bool -- ^ always link this unit - , luForeignRefs :: [ForeignJSRef] - } - --- | one toplevel block in the object file -data ObjUnit = ObjUnit - { oiSymbols :: ![FastString] -- ^ toplevel symbols (stored in index) - , oiClInfo :: ![ClosureInfo] -- ^ closure information of all closures in block - , oiStatic :: ![StaticInfo] -- ^ static closure data - , oiStat :: JStat -- ^ the code - , oiRaw :: !BS.ByteString -- ^ raw JS code - , oiFExports :: ![ExpFun] - , oiFImports :: ![ForeignJSRef] - } - -data ExpFun = ExpFun - { isIO :: !Bool - , args :: [JSFFIType] - , result :: !JSFFIType - } deriving (Eq, Ord, Show) - --- | Types of FFI values -data JSFFIType - = Int8Type - | Int16Type - | Int32Type - | Int64Type - | Word8Type - | Word16Type - | Word32Type - | Word64Type - | DoubleType - | ByteArrayType - | PtrType - | RefType - deriving (Show, Ord, Eq, Enum) - - --- | Typed expression -data TypedExpr = TypedExpr - { typex_typ :: !PrimRep - , typex_expr :: [JExpr] - } - -instance Outputable TypedExpr where - ppr x = text "TypedExpr: " <+> ppr (typex_expr x) - $$ text "PrimReps: " <+> ppr (typex_typ x) - --- | A Primop result is either an inlining of some JS payload, or a primitive --- call to a JS function defined in Shim files in base. -data PrimRes - = PrimInline JStat -- ^ primop is inline, result is assigned directly - | PRPrimCall JStat -- ^ primop is async call, primop returns the next - -- function to run. result returned to stack top in registers - -data ExprResult - = ExprCont - | ExprInline (Maybe [JExpr]) - deriving (Eq) - -newtype ExprValData = ExprValData [JExpr] - deriving newtype (Eq) - --- | A Closure is one of six types -data ClosureType - = Thunk -- ^ The closure is a THUNK - | Fun -- ^ The closure is a Function - | Pap -- ^ The closure is a Partial Application - | Con -- ^ The closure is a Constructor - | Blackhole -- ^ The closure is a Blackhole - | StackFrame -- ^ The closure is a stack frame - deriving (Show, Eq, Ord, Enum, Bounded) - --- | Convert 'ClosureType' to an Int -ctNum :: ClosureType -> Int -ctNum Fun = 1 -ctNum Con = 2 -ctNum Thunk = 0 -ctNum Pap = 3 -ctNum Blackhole = 5 -ctNum StackFrame = -1 - --- | Convert 'ClosureType' to a String -ctJsName :: ClosureType -> String -ctJsName = \case - Thunk -> "CLOSURE_TYPE_THUNK" - Fun -> "CLOSURE_TYPE_FUN" - Pap -> "CLOSURE_TYPE_PAP" - Con -> "CLOSURE_TYPE_CON" - Blackhole -> "CLOSURE_TYPE_BLACKHOLE" - StackFrame -> "CLOSURE_TYPE_STACKFRAME" - -instance ToJExpr ClosureType where - toJExpr e = toJExpr (ctNum e) - - --- | A thread is in one of 4 states -data ThreadStatus - = Running -- ^ The thread is running - | Blocked -- ^ The thread is blocked - | Finished -- ^ The thread is done - | Died -- ^ The thread has died - deriving (Show, Eq, Ord, Enum, Bounded) - --- | Convert the status of a thread in JS land to an Int -threadStatusNum :: ThreadStatus -> Int -threadStatusNum = \case - Running -> 0 - Blocked -> 1 - Finished -> 16 - Died -> 17 - --- | convert the status of a thread in JS land to a string -threadStatusJsName :: ThreadStatus -> String -threadStatusJsName = \case - Running -> "THREAD_RUNNING" - Blocked -> "THREAD_BLOCKED" - Finished -> "THREAD_FINISHED" - Died -> "THREAD_DIED" diff --git a/compiler/GHC/StgToJS/Utils.hs b/compiler/GHC/StgToJS/Utils.hs --- a/compiler/GHC/StgToJS/Utils.hs +++ b/compiler/GHC/StgToJS/Utils.hs @@ -1,27 +1,125 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module GHC.StgToJS.Utils ( assignToTypedExprs , assignCoerce1 , assignToExprCtx - ) -where + -- * Core Utils + , isUnboxableCon + , isUnboxable + , SlotCount(..) + , slotCount + , varSize + , varSlotCount + , typeSize + , isVoid + , isPtr + , isSingleVar + , isMultiVar + , isMatchable + , tyConVt + , idVt + , typeVt + , uTypeVt + , primRepVt + , typePrimRep' + , tyConPrimRep' + , kindPrimRep' + , primTypeVt + , argVt + , dataConType + , isBoolDataCon + , fixedLayout + , stackSlotType + , idPrimReps + , typePrimReps + , primRepSize + , assocPrimReps + , assocIdPrimReps + , assocIdExprs + , mkArityTag + , toTypeList + -- * Stg Utils + , bindingRefs + , rhsRefs + , exprRefs + , altRefs + , argRefs + , hasExport + , collectTopIds + , collectIds + , removeTick + , LiveVars + , liveStatic + , liveVars + , stgTopBindLive + , stgBindLive + , stgBindRhsLive + , stgRhsLive + , stgArgLive + , stgExprLive + , stgAltLive + , stgLetNoEscapeLive + , bindees + , isUpdatableRhs + , stgLneLive + , stgLneLive' + , stgLneLiveExpr + , isInlineExpr + , inspectInlineBinding + , inspectInlineRhs + , isInlineForeignCall + , isInlineApp + ) where import GHC.Prelude import GHC.StgToJS.Types import GHC.StgToJS.ExprCtx -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make +import GHC.JS.Transform +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep hiding (typeSize) import GHC.Core.TyCon +import GHC.Core.Type hiding (typeSize) +import GHC.Stg.Syntax + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names +import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) + +import GHC.Types.RepType +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.ForeignCall +import GHC.Types.TyThing +import GHC.Types.Name + import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic -import GHC.Utils.Outputable -assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat +import qualified Data.Bits as Bits +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.List as L +import Data.Set (Set) +import Data.Monoid + + +assignToTypedExprs :: [TypedExpr] -> [JExpr] -> JStat assignToTypedExprs tes es = assignAllEqual (concatMap typex_expr tes) es @@ -30,28 +128,487 @@ -- TODO: check primRep (typex_typ) here? assignToTypedExprs tes (concatMap typex_expr es) -assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat +assignToExprCtx :: ExprCtx -> [JExpr] -> JStat assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es -- | Assign first expr only (if it exists), performing coercions between some -- PrimReps (e.g. StablePtr# and Addr#). -assignCoerce1 :: HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat +assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStat assignCoerce1 [x] [y] = assignCoerce x y assignCoerce1 [] [] = mempty -assignCoerce1 x y = pprPanic "assignCoerce1" +assignCoerce1 _x _y = pprPanic "assignCoerce1" (vcat [ text "lengths do not match" - , ppr x - , ppr y + -- FIXME: Outputable instance removed until JStg replaces JStat + -- , ppr x + -- , ppr y ]) -- | Assign p2 to p1 with optional coercion assignCoerce :: TypedExpr -> TypedExpr -> JStat -- Coercion between StablePtr# and Addr# -assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr UnliftedRep [sptr]) = mconcat +assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) = mconcat [ a_val |= var "h$stablePtrBuf" , a_off |= sptr ] -assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = +assignCoerce (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = sptr |= a_off assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + +-------------------------------------------------------------------------------- +-- Core Utils +-------------------------------------------------------------------------------- + +-- | can we unbox C x to x, only if x is represented as a Number +isUnboxableCon :: DataCon -> Bool +isUnboxableCon dc + | [t] <- dataConRepArgTys dc + , [t1] <- typeVt (scaledThing t) + = isUnboxable t1 && + dataConTag dc == 1 && + length (tyConDataCons $ dataConTyCon dc) == 1 + | otherwise = False + +-- | one-constructor types with one primitive field represented as a JS Number +-- can be unboxed +isUnboxable :: VarType -> Bool +isUnboxable DoubleV = True +isUnboxable IntV = True -- includes Char# +isUnboxable _ = False + +-- | Number of slots occupied by a PrimRep +data SlotCount + = NoSlot + | OneSlot + | TwoSlots + deriving (Show,Eq,Ord) + +instance Outputable SlotCount where + ppr = text . show + +-- | Return SlotCount as an Int +slotCount :: SlotCount -> Int +slotCount = \case + NoSlot -> 0 + OneSlot -> 1 + TwoSlots -> 2 + + +-- | Number of slots occupied by a value with the given VarType +varSize :: VarType -> Int +varSize = slotCount . varSlotCount + +varSlotCount :: VarType -> SlotCount +varSlotCount VoidV = NoSlot +varSlotCount LongV = TwoSlots -- hi, low +varSlotCount AddrV = TwoSlots -- obj/array, offset +varSlotCount _ = OneSlot + +typeSize :: Type -> Int +typeSize t = sum . map varSize . typeVt $ t + +isVoid :: VarType -> Bool +isVoid VoidV = True +isVoid _ = False + +isPtr :: VarType -> Bool +isPtr PtrV = True +isPtr _ = False + +isSingleVar :: VarType -> Bool +isSingleVar v = varSlotCount v == OneSlot + +isMultiVar :: VarType -> Bool +isMultiVar v = case varSlotCount v of + NoSlot -> False + OneSlot -> False + TwoSlots -> True + +-- | can we pattern match on these values in a case? +isMatchable :: [VarType] -> Bool +isMatchable [DoubleV] = True +isMatchable [IntV] = True +isMatchable _ = False + +tyConVt :: HasDebugCallStack => TyCon -> [VarType] +tyConVt = typeVt . mkTyConTy + +idVt :: HasDebugCallStack => Id -> [VarType] +idVt = typeVt . idType + +typeVt :: HasDebugCallStack => Type -> [VarType] +typeVt t | isRuntimeRepKindedTy t = [] +typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t) + +-- only use if you know it's not an unboxed tuple +uTypeVt :: HasDebugCallStack => UnaryType -> VarType +uTypeVt ut + | isRuntimeRepKindedTy ut = VoidV +-- | isRuntimeRepTy ut = VoidV + -- GHC panics on this otherwise + | Just (tc, ty_args) <- splitTyConApp_maybe ut + , length ty_args /= tyConArity tc = PtrV + | isPrimitiveType ut = (primTypeVt ut) + | otherwise = + case typePrimRep' ut of + [] -> VoidV + [pt] -> primRepVt pt + _ -> pprPanic "uTypeVt: not unary" (ppr ut) + +primRepVt :: HasDebugCallStack => PrimRep -> VarType +primRepVt VoidRep = VoidV +primRepVt (BoxedRep _) = PtrV -- fixme does ByteArray# ever map to this? +primRepVt IntRep = IntV +primRepVt Int8Rep = IntV +primRepVt Int16Rep = IntV +primRepVt Int32Rep = IntV +primRepVt WordRep = IntV +primRepVt Word8Rep = IntV +primRepVt Word16Rep = IntV +primRepVt Word32Rep = IntV +primRepVt Int64Rep = LongV +primRepVt Word64Rep = LongV +primRepVt AddrRep = AddrV +primRepVt FloatRep = DoubleV +primRepVt DoubleRep = DoubleV +primRepVt (VecRep{}) = error "uTypeVt: vector types are unsupported" + +typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep] +typePrimRep' ty = kindPrimRep' empty (typeKind ty) + +-- | Find the primitive representation of a 'TyCon'. Defined here to +-- avoid module loops. Call this only on unlifted tycons. +tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep] +tyConPrimRep' tc = kindPrimRep' empty res_kind + where + res_kind = tyConResKind tc + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- of values of types of this kind. +kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] +kindPrimRep' doc ki + | Just ki' <- coreView ki + = kindPrimRep' doc ki' +kindPrimRep' doc (TyConApp _typ [runtime_rep]) + = -- ASSERT( typ `hasKey` tYPETyConKey ) + runtimeRepPrimRep doc runtime_rep +kindPrimRep' doc ki + = pprPanic "kindPrimRep'" (ppr ki $$ doc) + +primTypeVt :: HasDebugCallStack => Type -> VarType +primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of + Nothing -> error "primTypeVt: not a TyCon" + Just tc + | tc == charPrimTyCon -> IntV + | tc == intPrimTyCon -> IntV + | tc == wordPrimTyCon -> IntV + | tc == floatPrimTyCon -> DoubleV + | tc == doublePrimTyCon -> DoubleV + | tc == int8PrimTyCon -> IntV + | tc == word8PrimTyCon -> IntV + | tc == int16PrimTyCon -> IntV + | tc == word16PrimTyCon -> IntV + | tc == int32PrimTyCon -> IntV + | tc == word32PrimTyCon -> IntV + | tc == int64PrimTyCon -> LongV + | tc == word64PrimTyCon -> LongV + | tc == addrPrimTyCon -> AddrV + | tc == stablePtrPrimTyCon -> AddrV + | tc == stableNamePrimTyCon -> PtrV + | tc == statePrimTyCon -> VoidV + | tc == proxyPrimTyCon -> VoidV + | tc == realWorldTyCon -> VoidV + | tc == threadIdPrimTyCon -> PtrV + | tc == weakPrimTyCon -> PtrV + | tc == arrayPrimTyCon -> ArrV + | tc == smallArrayPrimTyCon -> ArrV + | tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal + | tc == mutableArrayPrimTyCon -> ArrV + | tc == smallMutableArrayPrimTyCon -> ArrV + | tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal + | tc == mutVarPrimTyCon -> PtrV + | tc == mVarPrimTyCon -> PtrV + | tc == tVarPrimTyCon -> PtrV + | tc == bcoPrimTyCon -> PtrV -- unsupported? + | tc == stackSnapshotPrimTyCon -> PtrV + | tc == ioPortPrimTyCon -> PtrV -- unsupported? + | tc == anyTyCon -> PtrV + | tc == compactPrimTyCon -> PtrV -- unsupported? + | tc == eqPrimTyCon -> VoidV -- coercion token? + | tc == eqReprPrimTyCon -> VoidV -- role + | tc == unboxedUnitTyCon -> VoidV -- Void# + | otherwise -> PtrV -- anything else must be some boxed thing + +argVt :: StgArg -> VarType +argVt a = uTypeVt . stgArgType $ a + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +isBoolDataCon :: DataCon -> Bool +isBoolDataCon dc = isBoolTy (dataConType dc) + +-- standard fixed layout: payload types +-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames +fixedLayout :: [VarType] -> CILayout +fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts + +-- 2-var values might have been moved around separately, use DoubleV as substitute +-- ObjV is 1 var, so this is no problem for implicit metadata +stackSlotType :: Id -> VarType +stackSlotType i + | OneSlot <- varSlotCount otype = otype + | otherwise = DoubleV + where otype = uTypeVt (idType i) + +idPrimReps :: Id -> [PrimRep] +idPrimReps = typePrimReps . idType + +typePrimReps :: Type -> [PrimRep] +typePrimReps = typePrimRep . unwrapType + +primRepSize :: PrimRep -> SlotCount +primRepSize p = varSlotCount (primRepVt p) + +-- | Associate the given values to each RrimRep in the given order, taking into +-- account the number of slots per PrimRep +assocPrimReps :: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])] +assocPrimReps [] _ = [] +assocPrimReps (r:rs) vs = case (primRepSize r,vs) of + (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs + (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs + (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs + err -> pprPanic "assocPrimReps" (ppr $ map (satJExpr Nothing) <$> err) + +-- | Associate the given values to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdPrimReps :: Id -> [JExpr] -> [(PrimRep, [JExpr])] +assocIdPrimReps i = assocPrimReps (idPrimReps i) + +-- | Associate the given JExpr to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdExprs :: Id -> [JExpr] -> [TypedExpr] +assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) + +mkArityTag :: Int -> Int -> Int +mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) + +toTypeList :: [VarType] -> [Int] +toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) + +-------------------------------------------------------------------------------- +-- Stg Utils +-------------------------------------------------------------------------------- + +s :: a -> Set a +s = S.singleton + +l :: (a -> Set Id) -> [a] -> Set Id +l = F.foldMap + +-- | collect Ids that this binding refers to +-- (does not include the bindees themselves) +-- first argument is Id -> StgExpr map for unfloated arguments +bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id +bindingRefs u = \case + StgNonRec _ rhs -> rhsRefs u rhs + StgRec bs -> l (rhsRefs u . snd) bs + +rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id +rhsRefs u = \case + StgRhsClosure _ _ _ _ body _ -> exprRefs u body + StgRhsCon _ccs d _mu _ticks args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + +exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id +exprRefs u = \case + StgApp f args -> s f <> l (argRefs u) args + StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + StgOpApp _ args _ -> l (argRefs u) args + StgLit {} -> mempty + StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) + StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgTick _ expr -> exprRefs u expr + +altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id +altRefs u alt = exprRefs u (alt_rhs alt) + +argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id +argRefs u = \case + StgVarArg id + | Just e <- lookupUFM u id -> exprRefs u e + | otherwise -> s id + _ -> mempty + +hasExport :: CgStgBinding -> Bool +hasExport bnd = + case bnd of + StgNonRec b e -> isExportedBind b e + StgRec bs -> any (uncurry isExportedBind) bs + where + isExportedBind _i (StgRhsCon _cc con _ _ _ _) = + getUnique con == staticPtrDataConKey + isExportedBind _ _ = False + +collectTopIds :: CgStgBinding -> [Id] +collectTopIds (StgNonRec b _) = [b] +collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs + in seqList xs `seq` xs + +collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] +collectIds unfloated b = + let xs = map zapFragileIdInfo . + filter acceptId $ S.toList (bindingRefs unfloated b) + in seqList xs `seq` xs + where + acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] + -- the GHC.Prim module has no js source file + isForbidden i + | Just m <- nameModule_maybe (getName i) = m == gHC_PRIM + | otherwise = False + +removeTick :: CgStgExpr -> CgStgExpr +removeTick (StgTick _ e) = e +removeTick e = e + +----------------------------------------------------- +-- Live vars +-- +-- TODO: should probably be moved into GHC.Stg.LiveVars + +type LiveVars = DVarSet + +liveStatic :: LiveVars -> LiveVars +liveStatic = filterDVarSet isGlobalId + +liveVars :: LiveVars -> LiveVars +liveVars = filterDVarSet (not . isGlobalId) + +stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)] +stgTopBindLive = \case + StgTopLifted b -> stgBindLive b + StgTopStringLit {} -> [] + +stgBindLive :: CgStgBinding -> [(Id, LiveVars)] +stgBindLive = \case + StgNonRec b rhs -> [(b, stgRhsLive rhs)] + StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs + +stgBindRhsLive :: CgStgBinding -> LiveVars +stgBindRhsLive b = + let (bs, ls) = unzip (stgBindLive b) + in delDVarSetList (unionDVarSets ls) bs + +stgRhsLive :: CgStgRhs -> LiveVars +stgRhsLive = \case + StgRhsClosure _ _ _ args e _ -> delDVarSetList (stgExprLive True e) args + StgRhsCon _ _ _ _ args _ -> unionDVarSets (map stgArgLive args) + +stgArgLive :: StgArg -> LiveVars +stgArgLive = \case + StgVarArg occ -> unitDVarSet occ + StgLitArg {} -> emptyDVarSet + +stgExprLive :: Bool -> CgStgExpr -> LiveVars +stgExprLive includeLHS = \case + StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) + StgLit {} -> emptyDVarSet + StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) + StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) + StgCase e b _at alts + | includeLHS -> el `unionDVarSet` delDVarSet al b + | otherwise -> delDVarSet al b + where + al = unionDVarSets (map stgAltLive alts) + el = stgExprLive True e + StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgTick _ti e -> stgExprLive True e + +stgAltLive :: CgStgAlt -> LiveVars +stgAltLive alt = + delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) + +stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars +stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive" + +bindees :: CgStgBinding -> [Id] +bindees = \case + StgNonRec b _e -> [b] + StgRec bs -> map fst bs + +isUpdatableRhs :: CgStgRhs -> Bool +isUpdatableRhs (StgRhsClosure _ _ u _ _ _) = isUpdatable u +isUpdatableRhs _ = False + +stgLneLive' :: CgStgBinding -> [Id] +stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) + +stgLneLive :: CgStgBinding -> [Id] +stgLneLive (StgNonRec _b e) = stgLneLiveExpr e +stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs + +stgLneLiveExpr :: CgStgRhs -> [Id] +stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) +-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) +-- stgLneLiveExpr StgRhsCon {} = [] + +-- | returns True if the expression is definitely inline +isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool) +isInlineExpr v = \case + StgApp i args + -> (emptyUniqSet, isInlineApp v i args) + StgLit{} + -> (emptyUniqSet, True) + StgConApp{} + -> (emptyUniqSet, True) + StgOpApp (StgFCallOp f _) _ _ + -> (emptyUniqSet, isInlineForeignCall f) + StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t + -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) + StgOpApp (StgPrimOp op) _ _ + -> (emptyUniqSet, primOpIsReallyInline op) + StgOpApp (StgPrimCallOp _c) _ _ + -> (emptyUniqSet, True) + StgCase e b _ alts + ->let (_ve, ie) = isInlineExpr v e + v' = addOneToUniqSet v b + (vas, ias) = unzip $ map (isInlineExpr v') (fmap alt_rhs alts) + vr = L.foldl1' intersectUniqSets vas + in (vr, (ie || b `elementOfUniqSet` v) && and ias) + StgLet _ b e + -> isInlineExpr (inspectInlineBinding v b) e + StgLetNoEscape _ _b e + -> isInlineExpr v e + StgTick _ e + -> isInlineExpr v e + +inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id +inspectInlineBinding v = \case + StgNonRec i r -> inspectInlineRhs v i r + StgRec bs -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs + +inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id +inspectInlineRhs v i = \case + StgRhsCon{} -> addOneToUniqSet v i + StgRhsClosure _ _ ReEntrant _ _ _ -> addOneToUniqSet v i + _ -> v + +isInlineForeignCall :: ForeignCall -> Bool +isInlineForeignCall (CCall (CCallSpec _ cconv safety)) = + not (playInterruptible safety) && + not (cconv /= JavaScriptCallConv && playSafe safety) + +isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool +isInlineApp v i = \case + _ | isJoinId i -> False + [] -> isUnboxedTupleType (idType i) || + isStrictType (idType i) || + i `elementOfUniqSet` v + + [StgVarArg a] + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a + -> True + _ -> False diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs --- a/compiler/GHC/SysTools/Cpp.hs +++ b/compiler/GHC/SysTools/Cpp.hs @@ -98,6 +98,9 @@ [ "-D__SSE2__" | isSse2Enabled platform ] ++ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + let fma_def = + [ "-D__FMA__" | isFmaEnabled dflags ] + let avx_defs = [ "-D__AVX__" | isAvxEnabled dflags ] ++ [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ @@ -140,6 +143,7 @@ ++ map GHC.SysTools.Option th_defs ++ map GHC.SysTools.Option hscpp_opts ++ map GHC.SysTools.Option sse_defs + ++ map GHC.SysTools.Option fma_def ++ map GHC.SysTools.Option avx_defs ++ map GHC.SysTools.Option io_manager_defs ++ mb_macro_include @@ -199,17 +203,11 @@ -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath getGhcVersionPathName dflags unit_env = do - let candidates = case ghcVersionFile dflags of - -- the user has provided an explicit `ghcversion.h` file to use. - Just path -> [path] - -- otherwise, try to find it in the rts' include-dirs. - -- Note: only in the RTS include-dirs! not all preload units less we may - -- use a wrong file. See #25106 where a globally installed - -- /usr/include/ghcversion.h file was used instead of the one provided - -- by the rts. - Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of - Nothing -> [] - Just info -> ( "ghcversion.h") <$> collectIncludeDirs [info] + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) + return (( "ghcversion.h") <$> collectIncludeDirs ps) found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -70,6 +70,7 @@ neededLinkArgs :: LinkerInfo -> [Option] neededLinkArgs (GnuLD o) = o +neededLinkArgs (Mold o) = o neededLinkArgs (GnuGold o) = o neededLinkArgs (LlvmLLD o) = o neededLinkArgs (DarwinLD o) = o @@ -104,6 +105,10 @@ -- Set DT_NEEDED for all shared libraries. #10110. return (GnuLD $ map Option [-- ELF specific flag -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + | any ("mold" `isPrefixOf`) stdo = + return (Mold $ map Option [ --see Note [ELF needed shared libs] "-Wl,--no-as-needed"]) | any ("GNU gold" `isPrefixOf`) stdo = 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 @@ -10,7 +10,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Exception import GHC.Utils.Error 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 @@ -29,7 +29,6 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs -import GHC.Utils.Constants (isWindowsHost) import GHC.Utils.Panic import Data.List (tails, isPrefixOf) @@ -247,17 +246,14 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version - LLVM version 15.0.7 - ... - OR LLVM (http://llvm.org/): - LLVM version 14.0.6 + LLVM version 3.5.2 + ... -} hSetBinaryMode pout False - line1 <- hGetLine pout - mb_ver <- case parseLlvmVersion line1 of - mb_ver@(Just _) -> return mb_ver - Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line + _ <- hGetLine pout + vline <- hGetLine pout + let mb_ver = parseLlvmVersion vline hClose pin hClose pout hClose perr @@ -353,9 +349,7 @@ , "does not support object merging." ] optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args - -- N.B. Darwin's ld64 doesn't support response files. Consequently we only - -- use them on Windows where they are truly necessary. - if isWindowsHost + if toolSettings_ldSupportsResponseFiles (toolSettings dflags) then do mb_env <- getGccEnv args2 runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env 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 @@ -65,6 +65,7 @@ import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.BooleanFormula ( isUnsatisfied ) import Control.Monad import Control.Monad.Trans.Class @@ -1442,19 +1443,24 @@ -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils whenIsJust (hasStockDeriving cls) $ \_ -> expectNonDataFamTyCon dit - mk_eqn_originative dit + mk_eqn_originative cls dit | otherwise -> mk_eqn_anyclass where -- Use heuristics (checkOriginativeSideConditions) to determine whether -- stock or anyclass deriving should be used. - mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec - mk_eqn_originative dit@(DerivInstTys { dit_tc = tc - , dit_rep_tc = rep_tc }) = do + mk_eqn_originative :: Class -> DerivInstTys -> DerivM EarlyDerivSpec + mk_eqn_originative cls dit@(DerivInstTys { dit_tc = tc + , dit_rep_tc = rep_tc }) = do dflags <- getDynFlags - let isDeriveAnyClassEnabled = - deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + let isDeriveAnyClassEnabled + | canSafelyDeriveAnyClass cls + = deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + | otherwise + -- Pretend that the extension is enabled so that we won't suggest + -- enabling it. + = YesDeriveAnyClassEnabled -- See Note [Deriving instances for classes themselves] let dac_error @@ -1471,6 +1477,12 @@ , dsm_stock_gen_fns = gen_fns } CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + canSafelyDeriveAnyClass cls = + -- If the set of minimal required definitions is nonempty, + -- `DeriveAnyClass` will generate an instance with undefined methods or + -- associated types, so don't suggest enabling it. + isNothing $ isUnsatisfied (const False) (classMinimalDef cls) + {- ************************************************************************ * * @@ -1960,9 +1972,13 @@ case mechanism of DerivSpecStock{dsm_stock_dit = dit} -> data_cons_in_scope_check dit - DerivSpecNewtype{dsm_newtype_dit = dit} - -> do atf_coerce_based_error_checks - data_cons_in_scope_check dit + -- No need to 'data_cons_in_scope_check' for newtype deriving. + -- Additionally, we also don't need to mark the constructos as + -- used because newtypes are handled separately elsewhere. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Types + -- or #17328 for more. + DerivSpecNewtype{} + -> atf_coerce_based_error_checks DerivSpecAnyClass{} -> pure () DerivSpecVia{} 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 @@ -44,53 +44,56 @@ import GHC.Prelude -import GHC.Tc.Utils.Monad -import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs -import GHC.Types.FieldLabel + +import GHC.Tc.TyCl.Class ( substATBndrs ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate( newFamInst ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Type +import GHC.Tc.Validity ( checkValidCoAxBranch ) + +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) +import GHC.Core.Type +import GHC.Core.Class + import GHC.Types.Name.Reader import GHC.Types.Basic import GHC.Types.Fixity -import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.SourceText +import GHC.Types.Id.Make ( coerceId ) +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) +import GHC.Types.Var.Env +import GHC.Types.Var -import GHC.Tc.Instance.Family -import GHC.Core.FamInstEnv import GHC.Builtin.Names import GHC.Builtin.Names.TH -import GHC.Types.Id.Make ( coerceId ) import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids (primOpId) -import GHC.Types.SrcLoc -import GHC.Core.TyCon -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Zonk -import GHC.Tc.Validity ( checkValidCoAxBranch ) -import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types -import GHC.Core.Type -import GHC.Core.Class -import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) -import GHC.Types.Var.Env import GHC.Utils.Misc -import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme + import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.Bag +import GHC.Data.Maybe ( expectJust ) +import GHC.Unit.Module import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List ( find, partition, intersperse ) -import GHC.Data.Maybe ( expectJust ) -import GHC.Unit.Module -- | A declarative description of an auxiliary binding that should be -- generated. See @Note [Auxiliary binders]@ for a more detailed description @@ -1279,8 +1282,7 @@ show_arg b arg_ty | isUnliftedType arg_ty -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer - = with_conv $ - nlHsApps compose_RDR + = nlHsApps compose_RDR [mk_shows_app boxed_arg, mk_showString_app postfixMod] | otherwise = mk_showsPrec_app arg_prec arg @@ -1288,14 +1290,6 @@ arg = nlHsVar b boxed_arg = box "Show" arg arg_ty postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty - with_conv expr - | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty = - nested_compose_Expr - [ mk_showString_app ("(" ++ conv ++ " ") - , expr - , mk_showString_app ")" - ] - | otherwise = expr -- Fixity stuff is_infix = dataConIsInfix data_con @@ -1511,9 +1505,8 @@ eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, - word8ToWord_RDR , int8ToInt_RDR , - word16ToWord_RDR, int16ToInt_RDR, - word32ToWord_RDR, int32ToInt_RDR + int8DataCon_RDR, int16DataCon_RDR, int32DataCon_RDR, int64DataCon_RDR, + word8DataCon_RDR, word16DataCon_RDR, word32DataCon_RDR, word64DataCon_RDR :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") @@ -1616,15 +1609,14 @@ gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") -word8ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word8ToWord#") -int8ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int8ToInt#") - -word16ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word16ToWord#") -int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#") - -word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#") -int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#") - +int8DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I8#") +int16DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I16#") +int32DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I32#") +int64DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I64#") +word8DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W8#") +word16DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W16#") +word32DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W32#") +word64DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W64#") {- ************************************************************************ * * @@ -1807,7 +1799,7 @@ *must* generate a term-level evidence binding in order to instantiate the quantified constraint! In response, GHC currently chooses not to use such a quantified constraint. -See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact. +See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Equality. But this isn't the death knell for combining QuantifiedConstraints with GND. On the contrary, if we generate GND bindings in a slightly different way, then @@ -2299,7 +2291,7 @@ mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches) + = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last @@ -2327,7 +2319,7 @@ -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches') + = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2351,7 +2343,7 @@ mkRdrFunBindSE :: Arity -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity fun@(L loc fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches') + = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2413,7 +2405,6 @@ -- A mapping from a primitive type to a function that constructs its boxed -- version. --- NOTE: Int8#/Word8# will become Int/Word. boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] boxConTbl = [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon)) @@ -2421,28 +2412,20 @@ , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) - , (int8PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar int8ToInt_RDR)) - , (word8PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar word8ToWord_RDR)) - , (int16PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar int16ToInt_RDR)) - , (word16PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar word16ToWord_RDR)) - , (int32PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar int32ToInt_RDR)) - , (word32PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar word32ToWord_RDR)) + , (int8PrimTy, nlHsApp (nlHsVar int8DataCon_RDR)) + , (word8PrimTy, nlHsApp (nlHsVar word8DataCon_RDR)) + , (int16PrimTy, nlHsApp (nlHsVar int16DataCon_RDR)) + , (word16PrimTy, nlHsApp (nlHsVar word16DataCon_RDR)) + , (int32PrimTy, nlHsApp (nlHsVar int32DataCon_RDR)) + , (word32PrimTy, nlHsApp (nlHsVar word32DataCon_RDR)) + , (int64PrimTy, nlHsApp (nlHsVar int64DataCon_RDR)) + , (word64PrimTy, nlHsApp (nlHsVar word64DataCon_RDR)) ] -- | A table of postfix modifiers for unboxed values. +-- Following https://github.com/ghc-proposals/ghc-proposals/pull/596, +-- we use the ExtendedLiterals syntax for sized literals. postfixModTbl :: [(Type, String)] postfixModTbl = [(charPrimTy , "#" ) @@ -2450,22 +2433,14 @@ ,(wordPrimTy , "##") ,(floatPrimTy , "#" ) ,(doublePrimTy, "##") - ,(int8PrimTy, "#") - ,(word8PrimTy, "##") - ,(int16PrimTy, "#") - ,(word16PrimTy, "##") - ,(int32PrimTy, "#") - ,(word32PrimTy, "##") - ] - -primConvTbl :: [(Type, String)] -primConvTbl = - [ (int8PrimTy, "intToInt8#") - , (word8PrimTy, "wordToWord8#") - , (int16PrimTy, "intToInt16#") - , (word16PrimTy, "wordToWord16#") - , (int32PrimTy, "intToInt32#") - , (word32PrimTy, "wordToWord32#") + ,(int8PrimTy , "#Int8") + ,(word8PrimTy , "#Word8") + ,(int16PrimTy , "#Int16") + ,(word16PrimTy, "#Word16") + ,(int32PrimTy , "#Int32") + ,(word32PrimTy, "#Word32") + ,(int64PrimTy , "#Int64") + ,(word64PrimTy, "#Word64") ] litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] @@ -2780,19 +2755,19 @@ rep_tc_args' = substTys subst rep_tc_args -- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's. --- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType". +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". -- -- This is only used in the final zonking step when inferring -- the context for a derived instance. -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". -zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys -zonkDerivInstTys ze dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args }) = do - cls_tys' <- zonkTcTypesToTypesX ze cls_tys - tc_args' <- zonkTcTypesToTypesX ze tc_args - rep_tc_args' <- zonkTcTypesToTypesX ze rep_tc_args +zonkDerivInstTys :: DerivInstTys -> ZonkT TcM DerivInstTys +zonkDerivInstTys dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args }) = do + cls_tys' <- zonkTcTypesToTypesX cls_tys + tc_args' <- zonkTcTypesToTypesX tc_args + rep_tc_args' <- zonkTcTypesToTypesX rep_tc_args pure dit{ dit_cls_tys = cls_tys' , dit_tc_args = tc_args' , dit_rep_tc_args = rep_tc_args' 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 @@ -28,7 +28,9 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Errors.Types -import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate( newFamInst ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core.DataCon @@ -45,22 +47,23 @@ import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set (elemVarSet) + import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Builtin.Names -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad -import GHC.Driver.Session + import GHC.Utils.Error( Validity'(..), andValid ) -import GHC.Types.SrcLoc -import GHC.Data.Bag -import GHC.Types.Var.Env -import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Data.FastString import GHC.Utils.Misc + +import GHC.Driver.DynFlags +import GHC.Data.Bag +import GHC.Data.FastString import Language.Haskell.Syntax.Basic (FieldLabelString(..)) 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 @@ -30,6 +30,8 @@ import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor) +import GHC.Tc.Zonk.TcType ( zonkWC ) +import GHC.Tc.Zonk.Env ( ZonkFlexi(..), initZonkEnv ) import GHC.Core.Class import GHC.Core.DataCon @@ -672,7 +674,7 @@ ; final_specs <- iterate_deriv 1 initial_solutions -- After simplification finishes, zonk the TcTyVars as described -- in Note [Overlap and deriving]. - ; traverse zonkDerivSpec final_specs } + ; initZonkEnv DefaultFlexi $ traverse zonkDerivSpec final_specs } where ------------------------------------------------------------------ -- The initial solutions for the equations claim that each @@ -756,7 +758,7 @@ solveWanteds wanteds -- It's not yet zonked! Obviously zonk it before peering at it - ; solved_wanteds <- zonkWC solved_wanteds + ; solved_wanteds <- liftZonkM $ zonkWC solved_wanteds -- See [STEP DAC HOIST] -- From the simplified constraints extract a subset 'good' that will @@ -768,8 +770,8 @@ -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is -- suitable to be inferred in the context of a derived instance. -- Returns @Nothing@ if the Ct is too exotic. - -- See Note [Exotic derived instance contexts] for what - -- constitutes an exotic constraint. + -- See (VD2) in Note [Valid 'deriving' predicate] in + -- GHC.Tc.Validity for what constitutes an exotic constraint. get_good :: Ct -> Maybe PredType get_good ct | validDerivPred head_size p = Just p | otherwise = Nothing @@ -798,8 +800,9 @@ min_theta_vars solved_wanteds -- This call to simplifyTop is purely for error reporting -- See Note [Error reporting for deriving clauses] - -- See also Note [Exotic derived instance contexts], which are caught - -- in this line of code. + -- See also Note [Valid 'deriving' predicate] in GHC.Tc.Validity, as this + -- line of code catches "exotic" constraints like the ones described in + -- (VD2) of that Note. ; simplifyTopImplic leftover_implic ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr min_theta) @@ -807,7 +810,7 @@ -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys - -- See Note [Exotic derived instance contexts] + -- See Note [Valid 'deriving' predicate] in GHC.Tc.Validity ; return min_theta } @@ -1008,7 +1011,8 @@ cannot solve, which might include: 1. Insoluble constraints -2. "Exotic" constraints (See Note [Exotic derived instance contexts]) +2. "Exotic" constraints (See Note [Valid 'deriving' predicate] in + GHC.Tc.Validity) Then we report an error immediately in simplifyDeriv. @@ -1029,55 +1033,4 @@ all the constraints in , then everything is hunky-dory. But if contains, say, an insoluble constraint, then (Foo a) won't be able to solve it, causing GHC to error. - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a 'derived' instance declaration, we *infer* the context. It's a -bit unclear what rules we should apply for this; the Haskell report is -silent. Obviously, constraints like (Eq a) are fine, but what about - data T f a = MkT (f a) deriving( Eq ) -where we'd get an Eq (f a) constraint. That's probably fine too. - -One could go further: consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -XUndecidableInstances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). - -The bottom line -~~~~~~~~~~~~~~~ -Allow constraints which consist only of type variables, with no repeats. -} diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -39,7 +39,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify (tcSubTypeSigma) -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Core.Class import GHC.Core.DataCon @@ -66,7 +66,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Error -import GHC.Utils.Unique (sameUnique) import Control.Monad.Trans.Reader import Data.Foldable (traverse_) @@ -231,22 +230,22 @@ setDerivSpecTheta theta ds = ds{ds_theta = theta} -- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's. --- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType". +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". -- -- This is only used in the final zonking step when inferring -- the context for a derived instance. -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". -zonkDerivSpec :: DerivSpec ThetaType -> TcM (DerivSpec ThetaType) +zonkDerivSpec :: DerivSpec ThetaType -> ZonkTcM (DerivSpec ThetaType) zonkDerivSpec ds@(DS { ds_tvs = tvs, ds_theta = theta , ds_tys = tys, ds_mechanism = mechanism - }) = do - (ze, tvs') <- zonkTyBndrs tvs - theta' <- zonkTcTypesToTypesX ze theta - tys' <- zonkTcTypesToTypesX ze tys - mechanism' <- zonkDerivSpecMechanism ze mechanism - pure ds{ ds_tvs = tvs', ds_theta = theta' - , ds_tys = tys', ds_mechanism = mechanism' - } + }) = + runZonkBndrT (zonkTyBndrsX tvs) $ \ tvs' -> do + theta' <- zonkTcTypesToTypesX theta + tys' <- zonkTcTypesToTypesX tys + mechanism' <- zonkDerivSpecMechanism mechanism + pure ds{ ds_tvs = tvs', ds_theta = theta' + , ds_tys = tys', ds_mechanism = mechanism' + } -- | What action to take in order to derive a class instance. -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as @@ -308,26 +307,26 @@ isDerivSpecVia _ = False -- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's. --- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType". +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". -- -- This is only used in the final zonking step when inferring -- the context for a derived instance. -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". -zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism -zonkDerivSpecMechanism ze mechanism = +zonkDerivSpecMechanism :: DerivSpecMechanism -> ZonkTcM DerivSpecMechanism +zonkDerivSpecMechanism mechanism = case mechanism of DerivSpecStock { dsm_stock_dit = dit , dsm_stock_gen_fns = gen_fns } -> do - dit' <- zonkDerivInstTys ze dit + dit' <- zonkDerivInstTys dit pure $ DerivSpecStock { dsm_stock_dit = dit' , dsm_stock_gen_fns = gen_fns } DerivSpecNewtype { dsm_newtype_dit = dit , dsm_newtype_rep_ty = rep_ty } -> do - dit' <- zonkDerivInstTys ze dit - rep_ty' <- zonkTcTypeToTypeX ze rep_ty + dit' <- zonkDerivInstTys dit + rep_ty' <- zonkTcTypeToTypeX rep_ty pure $ DerivSpecNewtype { dsm_newtype_dit = dit' , dsm_newtype_rep_ty = rep_ty' } @@ -337,9 +336,9 @@ , dsm_via_inst_ty = inst_ty , dsm_via_ty = via_ty } -> do - cls_tys' <- zonkTcTypesToTypesX ze cls_tys - inst_ty' <- zonkTcTypeToTypeX ze inst_ty - via_ty' <- zonkTcTypeToTypeX ze via_ty + cls_tys' <- zonkTcTypesToTypesX cls_tys + inst_ty' <- zonkTcTypeToTypeX inst_ty + via_ty' <- zonkTcTypeToTypeX via_ty pure $ DerivSpecVia { dsm_via_cls_tys = cls_tys' , dsm_via_inst_ty = inst_ty' , dsm_via_ty = via_ty' @@ -894,37 +893,37 @@ -- class for which stock deriving isn't possible. stockSideConditions :: DerivContext -> Class -> Maybe Condition stockSideConditions deriv_ctxt cls - | sameUnique cls_key eqClassKey = Just (cond_std `andCond` cond_args cls) - | sameUnique cls_key ordClassKey = Just (cond_std `andCond` cond_args cls) - | sameUnique cls_key showClassKey = Just (cond_std `andCond` cond_args cls) - | sameUnique cls_key readClassKey = Just (cond_std `andCond` cond_args cls) - | sameUnique cls_key enumClassKey = Just (cond_std `andCond` cond_isEnumeration) - | sameUnique cls_key ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | sameUnique cls_key boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | sameUnique cls_key dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` - cond_vanilla `andCond` - cond_args cls) - | sameUnique cls_key functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` - cond_vanilla `andCond` - cond_functorOK True False) - | sameUnique cls_key foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` - cond_vanilla `andCond` - cond_functorOK False True) - -- Functor/Fold/Trav works ok - -- for rank-n types - | sameUnique cls_key traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` - cond_vanilla `andCond` - cond_functorOK False False) - | sameUnique cls_key genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_RepresentableOk) - | sameUnique cls_key gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_Representable1Ok) - | sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` - cond_vanilla `andCond` - cond_args cls) - | otherwise = Nothing + | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) + | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` + cond_vanilla `andCond` + cond_args cls) + | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` + cond_vanilla `andCond` + cond_functorOK True False) + | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` + cond_vanilla `andCond` + cond_functorOK False True) + -- Functor/Fold/Trav works ok + -- for rank-n types + | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` + cond_vanilla `andCond` + cond_functorOK False False) + | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_RepresentableOk) + | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_Representable1Ok) + | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` + cond_vanilla `andCond` + cond_args cls) + | otherwise = Nothing where cls_key = getUnique cls cond_std = cond_stdOK deriv_ctxt False 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 @@ -1,11 +1,11 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, @@ -18,7 +18,7 @@ import GHC.Prelude import GHC.Driver.Env (hsc_units) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic @@ -30,9 +30,9 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Env( tcInitTidyEnv ) +import GHC.Tc.Zonk.Type import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify ( checkTyVarEq ) +import GHC.Tc.Zonk.TcType import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm @@ -41,8 +41,7 @@ import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit ) import GHC.Types.Name -import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual - , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) +import GHC.Types.Name.Reader import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Set @@ -69,7 +68,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as O import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.FV ( fvVarList, unionFV ) import GHC.Data.Bag @@ -81,9 +79,9 @@ import Data.Foldable ( toList ) import Data.Function ( on ) import Data.List ( partition, sort, sortBy ) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE -import Data.Ord ( comparing ) +import Data.Ord ( comparing ) import qualified Data.Semigroup as S {- @@ -217,7 +215,7 @@ , text "scope holes:" <+> ppr out_of_scope_holes ] ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - ; wanted <- zonkWC wanted -- Zonk to reveal all information + ; wanted <- liftZonkM $ zonkWC wanted -- Zonk to reveal all information ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs free_tvs = filterOut isCoVar $ @@ -335,7 +333,7 @@ , ic_given = given , ic_wanted = wanted, ic_binds = evb , ic_status = status, ic_info = info - , ic_env = tcl_env + , ic_env = ct_loc_env , ic_tclvl = tc_lvl }) | BracketSkol <- info , not insoluble @@ -350,13 +348,13 @@ , text "skols: " <+> pprTyVars tvs , text "tidy skols:" <+> pprTyVars tvs' ] - ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs + ; when bad_telescope $ reportBadTelescope ctxt ct_loc_env info tvs -- Do /not/ use the tidied tvs because then are in the -- wrong order, so tidying will rename things wrongly ; reportWanteds ctxt' tc_lvl wanted -- Report redundant (unused) constraints - ; warnRedundantConstraints ctxt' tcl_env info' dead_givens } + ; warnRedundantConstraints ctxt' ct_loc_env info' dead_givens } where insoluble = isInsolubleStatus status (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $ @@ -390,7 +388,7 @@ IC_BadTelescope -> True _ -> False -warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () +warnRedundantConstraints :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [EvVar] -> TcM () -- See Note [Tracking redundant constraints] in GHC.Tc.Solver warnRedundantConstraints ctxt env info redundant_evs | not (cec_warn_redundant ctxt) @@ -409,24 +407,21 @@ | SigSkol user_ctxt _ _ <- info -- When dealing with a user-written type signature, -- we want to add "In the type signature for f". - = restoreLclEnv env $ - setSrcSpan (redundantConstraintsSpan user_ctxt) $ - report_redundant_msg True - -- ^^^^ add "In the type signature..." + = report_redundant_msg True (setCtLocEnvLoc env (redundantConstraintsSpan user_ctxt)) + -- ^^^^ add "In the type signature..." | otherwise -- But for InstSkol there already *is* a surrounding -- "In the instance declaration for Eq [a]" context -- and we don't want to say it twice. Seems a bit ad-hoc - = restoreLclEnv env - $ report_redundant_msg False - -- ^^^^^ don't add "In the type signature..." + = report_redundant_msg False env + -- ^^^^^ don't add "In the type signature..." where report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic + -> CtLocEnv -> TcRn () - report_redundant_msg show_info - = do { lcl_env <- getLclEnv - ; msg <- + report_redundant_msg show_info lcl_env + = do { msg <- mkErrorReport lcl_env (TcRnRedundantConstraints redundant_evs (info, show_info)) @@ -434,7 +429,7 @@ [] ; reportDiagnostic msg } -reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () +reportBadTelescope :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols = do { msg <- mkErrorReport env @@ -476,11 +471,12 @@ ; (suppress, m_evdest) <- case ctEvidence ct of CtGiven {} -> return (False, Nothing) CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } - -> do { supp <- anyUnfilledCoercionHoles rewriters - ; return (supp, Just dest) } + -> do { rewriters' <- zonkRewriterSet rewriters + ; return (not (isEmptyRewriterSet rewriters'), Just dest) } - ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason - _ -> Nothing + ; let m_reason = case ct of + CIrredCan (IrredCt { ir_reason = reason }) -> Just reason + _ -> Nothing ; return $ Just $ EI { ei_pred = ctPred ct , ei_evdest = m_evdest @@ -506,20 +502,24 @@ , text "tidy_items1 =" <+> ppr tidy_items1 , text "tidy_errs =" <+> ppr tidy_errs ]) - -- Catch an awkward case in which /all/ errors are suppressed: - -- see Wrinkle at end of Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint - -- Unless we are sure that an error will be reported some other way (details - -- in the defn of tidy_items) un-suppress the lot. This makes sure we don't forget to - -- report an error at all, which is catastrophic: GHC proceeds to desguar and optimise - -- the program, even though it is full of type errors (#22702, #22793) + -- Catch an awkward (and probably rare) case in which /all/ errors are + -- suppressed: see Wrinkle (WRW2) in Note [Prioritise Wanteds with empty + -- RewriterSet] in GHC.Tc.Types.Constraint. + -- + -- Unless we are sure that an error will be reported some other way + -- (details in the defn of tidy_items) un-suppress the lot. This makes + -- sure we don't forget to report an error at all, which is + -- catastrophic: GHC proceeds to desguar and optimise the program, even + -- though it is full of type errors (#22702, #22793) ; errs_already <- ifErrsM (return True) (return False) ; let tidy_items | not errs_already -- Have not already reported an error (perhaps -- from an outer implication); see #21405 , not (any ignoreConstraint simples) -- No error is ignorable (is reported elsewhere) , all ei_suppress tidy_items1 -- All errors are suppressed - = map unsuppressErrorItem tidy_items1 - | otherwise = tidy_items1 + = map unsuppressErrorItem tidy_items1 + | otherwise + = tidy_items1 -- First, deal with any out-of-scope errors: ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs @@ -602,6 +602,7 @@ -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) + -- (Handles TypeError and Unsatisfiable) , given_eq_spec , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) @@ -614,7 +615,7 @@ -- where alpha is untouchable; and representational equalities -- Prefer homogeneous equalities over hetero, because the -- former might be holding up the latter. - -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical + -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) ] @@ -657,7 +658,12 @@ non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) non_tv_eq _ _ = False - is_user_type_error item _ = isUserTypeError (errorItemPred item) + -- Catch TypeError and Unsatisfiable. + -- Here, we want any nested TypeErrors to bubble up, so we use + -- 'containsUserTypeError' and not 'isTopLevelUserTypeError'. + -- + -- See also Note [Implementation of Unsatisfiable constraints], point (F). + is_user_type_error item _ = containsUserTypeError (errorItemPred item) is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2 @@ -800,16 +806,141 @@ If there is any trouble, checkValidFamInst bleats, aborting compilation. --} +Note [Implementation of Unsatisfiable constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst). +See Note [The Unsatisfiable constraint] in GHC.TypeError. +Its implementation consists of the following: + A. The definitions. + The Unsatisfiable class is defined in GHC.TypeError, in base. + It consists of the following definitions: + + type Unsatisfiable :: ErrorMessage -> Constraint + class Unsatisfiable msg where + unsatisfiableLifted :: a + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + unsatisfiable = unsatisfiableLifted @msg @((##) -> a) (##) + + The class TyCon as well as the unsatisfiable Id have known-key Names + in GHC; they are not wired-in. + + B. Unsatisfiable instances. + + The Unsatisfiable typeclass has no instances (see GHC.Tc.Instance.Class.matchGlobalInst). + + Users are prevented from writing instances in GHC.Tc.Validity.check_special_inst_head. + This is done using the same mechanism as for, say, Coercible or WithDict. + + C. Using [G] Unsatisfiable msg to solve any Wanted. + + In GHC.Tc.Solver.simplifyTopWanteds, after defaulting happens, when an + implication contains Givens of the form [G] Unsatisfiable msg, and the + implication supports term-level evidence (as per Note [Coercion evidence only] + in GHC.Tc.Types.Evidence), we use any such Given to solve all the Wanteds + in that implication. See GHC.Tc.Solver.useUnsatisfiableGivens. + + The way we construct the evidence terms is slightly complicated by + Type vs Constraint considerations; see Note [Evidence terms from Unsatisfiable Givens] + in GHC.Tc.Solver. + + The proposal explains why this happens after defaulting: if there are other + ways to solve the Wanteds, we would prefer to use that, as that will make + user programs "as defined as possible". + + Wrinkle [Ambiguity] + + We also use an Unsatisfiable Given to solve Wanteds when performing an + ambiguity check. See the call to "useUnsatisfiableGivens" in + GHC.Tc.Solver.simplifyAmbiguityCheck. + + This is, for example, required to typecheck the definition + of "unsatisfiable" itself: + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + + The ambiguity check on this type signature will produce + + [G] Unsatisfiable msg1, [W] Unsatisfiable msg2 + + and we want to ensure the Given solves the Wanted, to accept the definition. + + NB: + + An alternative would be to add a functional dependency on Unsatisfiable: + + class Unsatisfiable msg | -> msg + + Then we would unify msg1 and msg2 in the above constraint solving problem, + and would be able to solve the Wanted using the Given in the normal way. + However, adding such a functional dependency solely for this purpose + could have undesirable consequences. For example, one might have + + [W] Unsatisfiable (Text "msg1"), [W] Unsatisfiable (Text "msg2") + + and W-W fundep interaction would produce the insoluble constraint + + [W] "msg1" ~ "msg2" + + which we definitely wouldn't want to report to the user. + + D. Adding "meth = unsatisfiable @msg" method bindings. + + When a class instance has an "Unsatisfiable msg" constraint in its context, + and the user has omitted methods, we add method bindings of the form + "meth = unsatisfiable @msg". + See GHC.Tc.TyCl.Instance.tcMethods, in particular "tc_default". + + Example: + + class C a where { op :: a -> a } + instance Unsatisfiable Msg => C [a] where {} + + elaborates to + + instance Unsatisfiable Msg => C [a] where { op = unsatisfiable @Msg } + + due to the (Unsatisfiable Msg) constraint in the instance context. + + We also switch off the "missing methods" warning in this situation. + See "checkMinimalDefinition" in GHC.Tc.TyCl.Instance.tcMethods. + + Note that we do this even when there is a default method available. This + ensures we run into the unsatisfiable error message when deferring type + errors; otherwise we could end up with a runtime loop as seen in #23816. + + E. Switching off functional dependency coverage checks when there is + an "Unsatisfiable msg" context. + + This is because we want to allow users to rule out certain instances with + an "unsatisfiable" error, even when that would violate a functional + dependency. For example: + + class C a b | a -> b + instance Unsatisfiable (Text "No") => C a b + + See GHC.Tc.Instance.FunDeps.checkInstCoverage. + + F. Error reporting of "Unsatisfiable msg" constraints. + + This is done in GHC.Tc.Errors.reportWanteds: we detect when a constraint + is of the form "Unsatisfiable msg" and just emit the custom message + as an error to the user. + + This is the only way that "Unsatisfiable msg" constraints are reported, + which makes their behaviour much more predictable than TypeError. +-} + + -------------------------------------------- -- Reporters -------------------------------------------- type Reporter - = SolverReportErrCtxt -> [ErrorItem] -> TcM () + = SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM () type ReporterSpec = ( String -- Name , ErrorItem -> Pred -> Bool -- Pick these ones @@ -820,10 +951,10 @@ -- Suppress duplicates with either the same LHS, or same location -- Pre-condition: all items are equalities mkSkolReporter ctxt items - = mapM_ (reportGroup mkEqErr ctxt) (group items) + = mapM_ (reportGroup mkEqErr ctxt) (group (toList items)) where group [] = [] - group (item:items) = (item : yeses) : group noes + group (item:items) = (item :| yeses) : group noes where (yeses, noes) = partition (group_with item) items @@ -841,7 +972,8 @@ holes' = filter (keepThisHole severity) holes -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError` -- because otherwise types will be zonked and tidied many times over. - (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') + (tidy_env', lcl_name_cache) <- liftZonkM $ + zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') let ctxt' = ctxt { cec_tidy = tidy_env' } forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole ; reportDiagnostic msg } @@ -858,19 +990,19 @@ SevIgnore -> False _ -> True --- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole. +-- | zonkTidyTcLclEnvs takes a bunch of 'CtLocEnv's, each from a Hole. -- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied --- type for each Id in any of the binder stacks in the 'TcLclEnv's. +-- type for each Id in any of the binder stacks in the 'CtLocEnv's. -- Since there is a huge overlap between these stacks, is is much, -- much faster to do them all at once, avoiding duplication. -zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type) -zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls) +zonkTidyTcLclEnvs :: TidyEnv -> [CtLocEnv] -> ZonkM (TidyEnv, NameEnv Type) +zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap ctl_bndrs lcls) where go envs tc_bndr = case tc_bndr of TcTvBndr {} -> return envs TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs TcIdBndr_ExpType name et _top_lvl -> - do { mb_ty <- readExpType_maybe et + do { mb_ty <- liftIO $ readExpType_maybe et -- et really should be filled in by now. But there's a chance -- it hasn't, if, say, we're reporting a kind error en route to -- checking a term. See test indexed-types/should_fail/T8129 @@ -932,18 +1064,23 @@ mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item - ; maybeReportError ctxt [item] err + ; maybeReportError ctxt (item :| []) err ; addDeferredBinding ctxt err item } mkUserTypeError :: ErrorItem -> TcSolverReportMsg -mkUserTypeError item = - case getUserTypeErrorMsg (errorItemPred item) of - Just msg -> UserTypeError msg - Nothing -> pprPanic "mkUserTypeError" (ppr item) +mkUserTypeError item + | Just msg <- getUserTypeErrorMsg pty + = UserTypeError msg + | Just msg <- isUnsatisfiableCt_maybe pty + = UnsatisfiableError msg + | otherwise + = pprPanic "mkUserTypeError" (ppr item) + where + pty = errorItemPred item mkGivenErrorReporter :: Reporter -- See Note [Given errors] -mkGivenErrorReporter ctxt items +mkGivenErrorReporter ctxt (item:|_) = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called @@ -960,7 +1097,6 @@ ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary ; reportDiagnostic msg } where - (item : _ ) = items -- Never empty (ty1, ty2) = getEqPredTys (errorItemPred item) ignoreErrorReporter :: Reporter @@ -1005,13 +1141,13 @@ find one, we report the insoluble Given. -} -mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) +mkGroupReporter :: (SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, -- and report only the first (to avoid a cascade) mkGroupReporter mk_err ctxt items - = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items) + = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc (toList items)) eq_lhs_type :: ErrorItem -> ErrorItem -> Bool eq_lhs_type item1 item2 @@ -1027,7 +1163,7 @@ -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter +reportGroup :: (SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt items = do { err <- mk_err ctxt items ; traceTc "About to maybeReportErr" $ @@ -1051,11 +1187,11 @@ nonDeferrableOrigin _ = False maybeReportError :: SolverReportErrCtxt - -> [ErrorItem] -- items covered by the Report + -> NonEmpty ErrorItem -- items covered by the Report -> SolverReport -> TcM () -maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msg = important - , sr_supplementary = supp - , sr_hints = hints }) +maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important + , sr_supplementary = supp + , sr_hints = hints }) = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic || all ei_suppress items) $ -- if they're all to be suppressed, report nothing @@ -1068,7 +1204,6 @@ diag = TcRnSolverReport important reason hints msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp reportDiagnostic msg -maybeReportError _ _ _ = panic "maybeReportError" addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime] @@ -1081,11 +1216,11 @@ ; case dest of EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm + -> addTcEvBind ev_binds_var $ mkWantedEvBind evar True err_tm HoleDest hole -> do { -- See Note [Deferred errors for coercion holes] let co_var = coHoleCoVar hole - ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm + ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var True err_tm ; fillCoercionHole hole (mkCoVarCo co_var) } } addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given @@ -1127,11 +1262,10 @@ -- But suppress their error messages tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) items - | null yeses - = return (ctxt, items) - | otherwise - = do { traceTc "tryReporter{ " (text str <+> ppr yeses) +tryReporter ctxt (str, keep_me, suppress_after, reporter) items = case nonEmpty yeses of + Nothing -> pure (ctxt, items) + Just yeses -> do + { traceTc "tryReporter{ " (text str <+> ppr yeses) ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) ; let suppress_now = not no_errs && suppress_after -- See Note [Suppressing error messages] @@ -1144,7 +1278,7 @@ -- | Wrap an input 'TcRnMessage' with additional contextual information, -- such as relevant bindings or valid hole fits. -mkErrorReport :: TcLclEnv +mkErrorReport :: CtLocEnv -> TcRnMessage -- ^ The main payload of the message. -> Maybe SolverReportErrCtxt @@ -1155,7 +1289,7 @@ -- ^ Supplementary information, to be added at the end of the message. -> TcM (MsgEnvelope TcRnMessage) mkErrorReport tcl_env msg mb_ctxt supplementary - = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt + = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt ; unit_state <- hsc_units <$> getTopEnv ; hfdc <- getHoleFitDispConfig ; let @@ -1165,7 +1299,7 @@ (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) ; let detailed_msg = mkDetailedMessage err_info msg ; mkTcRnMessage - (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) + (RealSrcSpan (ctl_loc tcl_env) Strict.Nothing) (TcRnMessageWithInfo unit_state $ detailed_msg) } @@ -1271,23 +1405,14 @@ ************************************************************************ -} -mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkIrredErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkIrredErr ctxt items = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $ mkPlainMismatchMsg $ CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing ; return $ add_relevant_bindings binds msg } where - (item1:others) = final_items - - filtered_items = filter (not . ei_suppress) items - final_items | null filtered_items = items - -- they're all suppressed; must report *something* - -- NB: even though reportWanteds asserts that not - -- all items are suppressed, it's possible all the - -- irreducibles are suppressed, and so this function - -- might get all suppressed items - | otherwise = filtered_items + item1:|others = tryFilter (not . ei_suppress) items {- Note [Constructing Hole Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1328,15 +1453,9 @@ mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole - = do { dflags <- getDynFlags - ; rdr_env <- getGlobalRdrEnv - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; let (imp_errs, hints) - = unknownNameSuggestions WL_Anything - dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info occ + = do { (imp_errs, hints) + <- unknownNameSuggestions (ctl_rdr lcl_env) WL_Anything occ + ; let err = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs) report = SolverReport err [] hints @@ -1368,7 +1487,7 @@ ; (ctxt, hole_fits) <- if show_valid_hole_fits then validHoleFits ctxt tidy_simples hole else return (ctxt, noValidHoleFits) - ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty + ; (grouped_skvs, other_tvs) <- liftZonkM $ zonkAndGroupSkolTvs hole_ty ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt err = SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs @@ -1386,18 +1505,24 @@ -- | For all the skolem type variables in a type, zonk the skolem info and group together -- all the type variables with the same origin. -zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) +zonkAndGroupSkolTvs :: Type -> ZonkM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) zonkAndGroupSkolTvs hole_ty = do - zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list + zonked_info <- mapM zonk_skolem_info skolem_list return (zonked_info, other_tvs) where + zonk_skolem_info (sk, tv) = + do { sk <- zonkSkolemInfoAnon $ getSkolemInfo sk + ; return (sk, fst <$> tv) } tvs = tyCoVarsOfTypeList hole_ty - (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs + (skol_tvs, other_tvs) = partition (isTcTyVar <&&> isSkolemTyVar) tvs group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)]) - group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]] + group_skolems = bagToList <$> + UM.listToUniqMap_C unionBags + [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]] - skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems) + skolem_list = sortBy (comparing (sort . map snd . snd)) + $ UM.nonDetUniqMapToList group_skolems {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1461,20 +1586,18 @@ givenConstraints ctxt = do { implic@Implic{ ic_given = given } <- cec_encl ctxt ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } + ; return (varType constraint, getCtLocEnvLoc (ic_env implic)) } ---------------- -mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkIPErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport -- What would happen if an item is suppressed because of -- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear -- what's best. Let's not worry about this. -mkIPErr ctxt items +mkIPErr ctxt (item1:|others) = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) ; return $ add_relevant_bindings binds msg } - where - item1:others = items ---------------- @@ -1483,16 +1606,16 @@ -- but doesn't. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. -mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkFRRErr ctxt items = do { -- Process the error items. ; (_tidy_env, frr_infos) <- - zonkTidyFRRInfos (cec_tidy ctxt) $ + liftZonkM $ zonkTidyFRRInfos (cec_tidy ctxt) $ -- Zonk/tidy to show useful variable names. nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $ -- Remove duplicates: only one representation-polymorphism error per type. - map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe) - items + map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe) $ + toList items ; return $ important ctxt $ FixedRuntimeRepError frr_infos } -- | Whether to report something using the @FixedRuntimeRep@ mechanism. @@ -1567,17 +1690,10 @@ -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkEqErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkEqErr ctxt items - | item:_ <- filter (not . ei_suppress) items - = mkEqErr1 ctxt item - - | item:_ <- items -- they're all suppressed. still need an error message - -- for -fdefer-type-errors though - = mkEqErr1 ctxt item - - | otherwise - = panic "mkEqErr" -- guaranteed to have at least one item + | item1 :| _ <- tryFilter (not . ei_suppress) items + = mkEqErr1 ctxt item1 mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport mkEqErr1 ctxt item -- Wanted only @@ -1640,12 +1756,14 @@ mkEqErr_help ctxt item ty1 ty2 | Just casted_tv1 <- getCastedTyVar_maybe ty1 = mkTyVarEqErr ctxt item casted_tv1 ty2 + + -- ToDo: explain.. Cf T2627b Dual (Dual a) ~ a | Just casted_tv2 <- getCastedTyVar_maybe ty2 = mkTyVarEqErr ctxt item casted_tv2 ty1 + | otherwise - = do - err <- reportEqErr ctxt item ty1 ty2 - return (err, noHints) + = do { err <- reportEqErr ctxt item ty1 ty2 + ; return (err, noHints) } reportEqErr :: SolverReportErrCtxt -> ErrorItem @@ -1653,18 +1771,18 @@ -> TcM TcSolverReportMsg reportEqErr ctxt item ty1 ty2 = do - mb_coercible_info <- - if errorItemEqRel item == ReprEq - then coercible_msg ty1 ty2 - else return Nothing - return $ - Mismatch - { mismatchMsg = mismatch - , mismatchTyVarInfo = Nothing - , mismatchAmbiguityInfo = eqInfos - , mismatchCoercibleInfo = mb_coercible_info } + mb_coercible_info <- if errorItemEqRel item == ReprEq + then coercible_msg ty1 ty2 + else return Nothing + tv_info <- case getTyVar_maybe ty2 of + Nothing -> return Nothing + Just tv2 -> Just <$> extraTyVarEqInfo (tv2, Nothing) ty1 + return $ Mismatch { mismatchMsg = mismatch + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = eqInfos + , mismatchCoercibleInfo = mb_coercible_info } where - mismatch = misMatchOrCND False ctxt item ty1 ty2 + mismatch = misMatchOrCND ctxt item ty1 ty2 eqInfos = eqInfoMsgs ty1 ty2 coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg) @@ -1689,11 +1807,11 @@ -- alpha[conc] ~# rr[sk] ? If so, handle that first. | Just frr_info <- mb_concrete_reason = do - (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] + (_, infos) <- liftZonkM $ zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] return (FixedRuntimeRepError infos, []) - -- Impredicativity is a simple error to understand; try it before - -- anything more complicated. + -- Impredicativity is a simple error to understand; + -- try it before anything more complicated. | check_eq_result `cterHasProblem` cteImpredicative = do tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2 @@ -1713,27 +1831,34 @@ -- to be helpful since this is just an unimplemented feature. return (main_msg, []) + -- Incompatible kinds + -- This is wrinkle (EIK2) in Note [Equalities with incompatible kinds] + -- in GHC.Tc.Solver.Equality + | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2 + = return (mkBlockedEqErr item, []) + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have - -- swapped in Solver.Canonical.canEqTyVarHomo + -- swapped in Solver.Equality.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || errorItemEqRel item == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) = do tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 - reason <- - if errorItemEqRel item == ReprEq - then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2 - else return $ DifferentTyVars tv_extra - let main_msg = - CannotUnifyVariable - { mismatchMsg = headline_msg - , cannotUnifyReason = reason } + reason <- if errorItemEqRel item == ReprEq + then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2 + else return $ DifferentTyVars tv_extra + let main_msg = CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = reason } return (main_msg, add_sig) - | cterHasOccursCheck check_eq_result + | tv1 `elemVarSet` tyCoVarsOfType ty2 -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it + -- + -- Use tyCoVarsOfType because it might have begun as the canonical + -- constraint (Dual (Dual a)) ~ a, and been swizzled by mkEqnErr_help = let ambiguity_infos = eqInfoMsgs ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ @@ -1752,11 +1877,6 @@ in return (main_msg, []) - -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in - -- GHC.Tc.Solver.Canonical - | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2 - = return (mkBlockedEqErr item, []) - -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably -- it started life as a TyVarTv, else it'd have been unified, given @@ -1804,14 +1924,13 @@ return (msg, add_sig) | otherwise - = do - err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2 - return (err, []) + = do { err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2 + ; return (err, []) } -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where - headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 + headline_msg = misMatchOrCND ctxt item ty1 ty2 mismatch_msg = mkMismatchMsg item ty1 ty2 add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 @@ -1820,7 +1939,7 @@ -- there is an error is not sufficient. See #21430. mb_concrete_reason | Just frr_orig <- isConcreteTyVar_maybe tv1 - , not (isConcrete ty2) + , not (isConcreteType ty2) = Just $ frr_reason frr_orig tv1 ty2 | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2 , not (isConcreteTyVar tv1) @@ -1838,12 +1957,7 @@ check_eq_result = case ei_m_reason item of Just (NonCanonicalReason result) -> result - _ -> checkTyVarEq tv1 ty2 - -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type - -- variable is on the right, so we don't get useful info for the CIrredCan, - -- and have to compute the result of checkTyVarEq here. - - insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs + _ -> cteOK eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo] -- Report (a) ambiguity if either side is a type function application @@ -1878,11 +1992,11 @@ | otherwise = Nothing -misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem +misMatchOrCND :: SolverReportErrCtxt -> ErrorItem -> TcType -> TcType -> MismatchMsg -- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 - | insoluble_occurs_check -- See Note [Insoluble occurs check] +misMatchOrCND ctxt item ty1 ty2 + | insoluble_item -- See Note [Insoluble mis-match] || (isRigidTy ty1 && isRigidTy ty2) || (ei_flavour item == Given) || null givens @@ -1894,13 +2008,17 @@ = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2) where + insoluble_item = case ei_m_reason item of + Nothing -> False + Just r -> isInsolubleReason r + level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. -- See Note [Suppress redundant givens during error reporting] --- These are for the "blocked" equalities, as described in TcCanonical --- Note [Equalities with incompatible kinds], wrinkle (2). There should +-- These are for the "blocked" equalities, as described in GHC.Tc.Solver.Equality +-- Note [Equalities with incompatible kinds], wrinkle (EIK2). There should -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. @@ -1968,7 +2086,7 @@ extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ case tcTyVarDetails tv of SkolemTv skol_info lvl overlaps -> do - new_skol_info <- zonkSkolemInfo skol_info + new_skol_info <- liftZonkM $ zonkSkolemInfo skol_info return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps) _ -> return tv @@ -2012,13 +2130,22 @@ , teq_mismatch_expected = uo_expected , teq_mismatch_what = mb_thing , teq_mb_same_occ = sameOccExtras ty2 ty1 }) - KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> - (mkBasicMismatchMsg NoEA item ty1 ty2) - { mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k - , mismatch_mb_same_occ = mb_same_occ } - _ -> - (mkBasicMismatchMsg NoEA item ty1 ty2) - { mismatch_mb_same_occ = mb_same_occ } + KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> BasicMismatch + { mismatch_ea = NoEA + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k + , mismatch_mb_same_occ = mb_same_occ + } + _ -> BasicMismatch + { mismatch_ea = NoEA + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = mb_same_occ + } where orig = errorItemOrigin item mb_same_occ = sameOccExtras ty2 ty1 @@ -2042,8 +2169,8 @@ shouldPprWithExplicitKinds ty1 ty2 _ct = tcEqTypeVis ty1 ty2 -{- Note [Insoluble occurs check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Insoluble mis-match] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble so we don't use it for rewriting. The Wanted is also insoluble, and we don't solve it from the Given. It's very confusing to say @@ -2052,7 +2179,9 @@ And indeed even thinking about the Givens is silly; [W] a ~ [a] is just as insoluble as Int ~ Bool. -Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs) +Exactly the same is true if we have [G] Int ~ Bool, [W] Int ~ Bool. + +Conclusion: if there's an insoluble constraint (isInsolubleReason), then report it directly, not in the "cannot deduce X from Y" form. This is done in misMatchOrCND (via the insoluble_occurs_check arg) @@ -2142,10 +2271,9 @@ ************************************************************************ -} -mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport +mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkDictErr ctxt orig_items - = assert (not (null items)) $ - do { inst_envs <- tcGetInstEnvs + = do { inst_envs <- tcGetInstEnvs ; let min_items = elim_superclasses items lookups = map (lookup_cls_inst inst_envs) min_items (no_inst_items, overlap_items) = partition is_no_inst lookups @@ -2158,10 +2286,7 @@ ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items)) ; return $ important ctxt err } where - filtered_items = filter (not . ei_suppress) orig_items - items | null filtered_items = orig_items -- all suppressed, but must report - -- something for -fdefer-type-errors - | otherwise = filtered_items -- common case + items = tryFilter (not . ei_suppress) orig_items no_givens = null (getUserGivens ctxt) @@ -2179,7 +2304,7 @@ -- When simplifying [W] Ord (Set a), we need -- [W] Eq a, [W] Ord a -- but we really only want to report the latter - elim_superclasses items = mkMinimalBySCs errorItemPred items + elim_superclasses = mkMinimalBySCs errorItemPred . toList -- Note [mk_dict_err] -- ~~~~~~~~~~~~~~~~~~~ @@ -2198,7 +2323,7 @@ (Nothing, _) -> do -- No matches but perhaps several unifiers { (_, rel_binds, item) <- relevantBindings True ctxt item ; candidate_insts <- get_candidate_instances - ; (imp_errs, field_suggestions) <- record_field_suggestions + ; (imp_errs, field_suggestions) <- record_field_suggestions item ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } -- Some matches => overlap errors @@ -2234,21 +2359,36 @@ | otherwise = False -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: TcM ([ImportError], [GhcHint]) - record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name -> + record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint]) + record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name -> do { glb_env <- getGlobalRdrEnv ; lcl_env <- getLocalRdrEnv - ; if occ_name_in_scope glb_env lcl_env name - then return ([], noHints) - else do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod - glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } + ; let field_name_hints = report_no_fieldnames item + ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name + then return ([], noHints) + else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) + ; pure (errs, hints ++ field_name_hints) + } + -- get type names from instance + -- resolve the type - if it's in scope is it a record? + -- if it's a record, report an error - the record name + the field that could not be found + report_no_fieldnames :: ErrorItem -> [GhcHint] + report_no_fieldnames item + | Just (EvVarDest evvar) <- ei_evdest item + -- we can assume that here we have a `HasField @Symbol x r a` instance + -- because of HasFieldOrigin in record_field + , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar) + , Just (r_tycon, _) <- tcSplitTyConApp_maybe r + , Just x_name <- isStrLitTy x + -- we check that this is a record type by checking whether it has any + -- fields (in scope) + , not . null $ tyConFieldLabels r_tycon + = [RemindRecordMissingField x_name r a] + | otherwise = [] + occ_name_in_scope glb_env lcl_env occ_name = not $ - null (lookupGlobalRdrEnv glb_env occ_name) && + null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) && isNothing (lookupLocalRdrOcc lcl_env occ_name) record_field = case orig of @@ -2356,7 +2496,7 @@ -- Also returns the zonked and tidied CtOrigin of the constraint relevantBindings want_filtering ctxt item = do { traceTc "relevantBindings" (ppr item) - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + ; (env1, tidy_orig) <- liftZonkM $ zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) -- For *kind* errors, report the relevant bindings of the -- enclosing *type* equality, because that's more useful for the programmer @@ -2369,7 +2509,7 @@ loc' = setCtLocOrigin loc tidy_orig item' = item { ei_loc = loc' } - ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] + ; (env2, lcl_name_cache) <- liftZonkM $ zonkTidyTcLclEnvs env1 [lcl_env] ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs ; let ctxt' = ctxt { cec_tidy = env2 } @@ -2380,7 +2520,7 @@ -- slightly more general version, to work also with holes relevant_bindings :: Bool - -> TcLclEnv + -> CtLocEnv -> NameEnv Type -- Cache of already zonked and tidied types -> TyCoVarSet -> TcM RelevantBindings @@ -2389,13 +2529,13 @@ ; traceTc "relevant_bindings" $ vcat [ ppr ct_tvs , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] + | TcIdBndr id _ <- ctl_bndrs lcl_env ] , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] + [ ppr id | TcIdBndr_ExpType id _ _ <- ctl_bndrs lcl_env ] ] ; go dflags (maxRelevantBinds dflags) emptyVarSet (RelevantBindings [] False) - (removeBindingShadowing $ tcl_bndrs lcl_env) + (removeBindingShadowing $ ctl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first, -- which are probably the most relevant ones } @@ -2419,7 +2559,7 @@ TcTvBndr {} -> discard_it TcIdBndr id top_lvl -> go2 (idName id) top_lvl TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- readExpType_maybe et + do { mb_ty <- liftIO $ readExpType_maybe et -- et really should be filled in by now. But there's a chance -- it hasn't, if, say, we're reporting a kind error en route to -- checking a term. See test indexed-types/should_fail/T8129 @@ -2467,7 +2607,7 @@ = panic "warnDefaulting: empty Wanteds" warnDefaulting the_tv wanteds@(ct:_) default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv + ; env0 <- liftZonkM $ tcInitTidyEnv -- don't want to report all the superclass constraints, which -- add unhelpful clutter ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds @@ -2514,3 +2654,9 @@ CouldNotDeduce {} -> [] _ -> [] + +-- | Filter the list by the given predicate, but if that would be empty, +-- just give back the original list. +-- We use this as we must report something for fdefer-type-errors. +tryFilter :: (a -> Bool) -> NonEmpty a -> NonEmpty a +tryFilter f as = fromMaybe as $ nonEmpty (filter f (toList as)) 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ExistentialQuantification #-} module GHC.Tc.Errors.Hole @@ -23,7 +24,7 @@ , sortHoleFitsBySize - -- Re-exported from GHC.Tc.Errors.Hole.FitTypes + -- Re-exported from GHC.Tc.Errors.Hole.Plugin , HoleFitPlugin (..), HoleFitPluginR (..) ) where @@ -39,12 +40,15 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.TcType import GHC.Core.Type +import GHC.Core.TyCon( TyCon, isGenerativeTyCon ) +import GHC.Core.TyCo.Rep( Type(..) ) import GHC.Core.DataCon +import GHC.Core.Predicate( Pred(..), classifyPredType, eqRelRole ) import GHC.Types.Name -import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..) - , globalRdrEnvElts, greMangledName, grePrintableName ) -import GHC.Builtin.Names ( gHC_ERR ) +import GHC.Types.Name.Reader +import GHC.Builtin.Names ( gHC_ERR, uNSAFE_COERCE ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -55,7 +59,7 @@ import GHC.Utils.Panic import GHC.Tc.Utils.Env (tcLookup) import GHC.Utils.Outputable -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.Maybe import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) @@ -78,6 +82,7 @@ import GHC.Builtin.Utils (knownKeyNames) import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Errors.Hole.Plugin import qualified Data.Set as Set import GHC.Types.SrcLoc import GHC.Data.FastString (NonDetFastString(..)) @@ -527,7 +532,7 @@ holeDisp = if sMs then holeVs else sep $ replicate (length hfMatches) $ text "_" occDisp = case hfCand of - GreHFCand gre -> pprPrefixOcc (grePrintableName gre) + GreHFCand gre -> pprPrefixOcc (greName gre) NameHFCand name -> pprPrefixOcc name IdHFCand id_ -> pprPrefixOcc id_ tyDisp = ppWhen sTy $ dcolon <+> ppr hfType @@ -551,8 +556,8 @@ 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) } + = do { (env1, _) <- liftZonkM $ zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) + ; go env1 [] (removeBindingShadowing $ ctl_bndrs lcl_env) } where lcl_env = ctLocEnv ct_loc @@ -615,7 +620,7 @@ ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) ; (searchDiscards, subs) <- tcFilterHoleFits findVLimit hole (hole_ty, []) cands - ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs + ; (tidy_env, tidy_subs) <- liftZonkM $ zonkSubs tidy_env subs ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs @@ -638,13 +643,13 @@ else maxRSubs ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) cands) ref_tys - ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs + ; (tidy_env, tidy_rsubs) <- liftZonkM $ zonkSubs tidy_env $ concatMap snd refDs ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs -- For refinement substitutions we want matches -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t), -- and others in that vein to appear last, since these are -- unlikely to be the most relevant fits. - ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty + ; (tidy_env, tidy_hole_ty) <- liftZonkM $ zonkTidyTcType tidy_env hole_ty ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs ; plugin_handled_rsubs <- foldM (flip ($)) @@ -725,17 +730,17 @@ -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output. -zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) +zonkSubs :: TidyEnv -> [HoleFit] -> ZonkM (TidyEnv, [HoleFit]) zonkSubs = zonkSubs' [] where zonkSubs' zs env [] = return (env, reverse zs) zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf ; zonkSubs' (z:zs) env' hfs } - zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit) + zonkSub :: TidyEnv -> HoleFit -> ZonkM (TidyEnv, HoleFit) zonkSub env hf@RawHoleFit{} = return (env, hf) zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} = do { (env, ty') <- zonkTidyTcType env ty - ; (env, m') <- zonkTidyTcTypes env m + ; (env, m') <- zonkTidyTcTypes env m ; (env, wrp') <- zonkTidyTcTypes env wrp ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} ; return (env, zFit ) } @@ -818,8 +823,8 @@ _ -> discard_it } _ -> discard_it } where - -- We want to filter out undefined and the likes from GHC.Err - not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR + -- We want to filter out undefined and the likes from GHC.Err (#17940) + not_trivial id = nameModule_maybe (idName id) `notElem` [Just gHC_ERR, Just uNSAFE_COERCE] lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type)) lookup (IdHFCand id) = return (Just (id, idType id)) @@ -832,9 +837,9 @@ _ -> Nothing } where name = case hfc of #if __GLASGOW_HASKELL__ < 901 - IdHFCand id -> idName id + IdHFCand id -> idName id #endif - GreHFCand gre -> greMangledName gre + GreHFCand gre -> greName gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) @@ -903,7 +908,7 @@ -- holes must be for this to be a match. ; if fits then do { -- Zonking is expensive, so we only do it if required. - z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) + z_wrp_tys <- liftZonkM $ zonkTcTypes (unfoldWrapper wrp) ; if null ref_vars then return (Just (z_wrp_tys, [])) else do { let -- To be concrete matches, matches have to @@ -914,7 +919,7 @@ Just tv -> tv `elemVarSet` fvSet _ -> True allConcrete = all notAbstract z_wrp_tys - ; z_vars <- zonkTcTyVars ref_vars + ; z_vars <- liftZonkM $ zonkTcTyVars ref_vars ; let z_mtvs = mapMaybe getTyVar_maybe z_vars ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs ; allowAbstract <- goptM Opt_AbstractRefHoleFits @@ -982,28 +987,33 @@ tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted - ; 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 cloneWantedCtEv th_relevant_cts - -- We wrap the WC in the nested implications, for details, see - -- Note [Checking hole fits] - ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics - final_wc = wrapInImpls $ addSimples wanted $ - mapBag mkNonCanonical cloned_relevants - -- We add the cloned relevants to the wanteds generated - -- by the call to tcSubType_NC, for details, see - -- Note [Relevant constraints]. There's no need to clone - -- the wanteds, because they are freshly generated by the - -- call to`tcSubtype_NC`. - ; traceTc "final_wc is: " $ ppr final_wc - -- See Note [Speeding up valid hole-fits] - ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc - ; traceTc "}" empty - ; return (any isSolvedWC rem, wrap) } } + ; if | isEmptyWC wanted, isEmptyBag th_relevant_cts + -> do { traceTc "}" empty + ; return (True, wrap) } + + | checkInsoluble wanted -- See Note [Fast path for tcCheckHoleFit] + -> return (False, wrap) + + | otherwise + -> 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 cloneWantedCtEv th_relevant_cts + -- We wrap the WC in the nested implications, for details, see + -- Note [Checking hole fits] + ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics + final_wc = wrapInImpls $ addSimples wanted $ + mapBag mkNonCanonical cloned_relevants + -- We add the cloned relevants to the wanteds generated + -- by the call to tcSubType_NC, for details, see + -- Note [Relevant constraints]. There's no need to clone + -- the wanteds, because they are freshly generated by the + -- call to`tcSubtype_NC`. + ; traceTc "final_wc is: " $ ppr final_wc + -- See Note [Speeding up valid hole-fits] + ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc + ; traceTc "}" empty + ; return (any isSolvedWC rem, wrap) } } where orig = ExprHoleOrigin (hole_occ <$> th_hole) @@ -1013,3 +1023,52 @@ -> WantedConstraints -- The new constraints. setWCAndBinds binds imp wc = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } + +{- Note [Fast path for tcCheckHoleFit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `tcCheckHoleFit` we compare (with `tcSubTypeSigma`) the type of the hole +with the type of zillions of in-scope functions, to see which would "fit". +Most of these checks fail! They generate obviously-insoluble constraints. +For these very-common cases we don't want to crank up the full constraint +solver. It's much more efficient to do a quick-and-dirty check for insolubility. + +Now, `tcSubTypeSigma` uses the on-the-fly unifier in GHC.Tc.Utils.Unify, +it has already done the dirt-simple unification. So our quick-and-dirty +check can simply look for constraints like (Int ~ Bool). We don't need +to worry about (Maybe Int ~ Maybe Bool). + +The quick-and-dirty check is in `checkInsoluble`. It can make a big +difference: For test hard_hole_fits, compile-time allocation goes down by 37%! +-} + + +checkInsoluble :: WantedConstraints -> Bool +-- See Note [Fast path for tcCheckHoleFit] +checkInsoluble (WC { wc_simple = simples }) + = any is_insol simples + where + is_insol ct = case classifyPredType (ctPred ct) of + EqPred r t1 t2 -> definitelyNotEqual (eqRelRole r) t1 t2 + _ -> False + +definitelyNotEqual :: Role -> TcType -> TcType -> Bool +-- See Note [Fast path for tcCheckHoleFit] +-- Specifically, does not need to recurse under type constructors +definitelyNotEqual r t1 t2 + = go t1 t2 + where + go t1 t2 + | Just t1' <- coreView t1 = go t1' t2 + | Just t2' <- coreView t2 = go t1 t2' + + go (TyConApp tc _) t2 | isGenerativeTyCon tc r = go_tc tc t2 + go t1 (TyConApp tc _) | isGenerativeTyCon tc r = go_tc tc t1 + go (FunTy {ft_af = af1}) (FunTy {ft_af = af2}) = af1 /= af2 + go _ _ = False + + go_tc :: TyCon -> TcType -> Bool + -- The TyCon is generative, and is not a saturated FunTy + go_tc tc1 (TyConApp tc2 _) | isGenerativeTyCon tc2 r = tc1 /= tc2 + go_tc _ (FunTy {}) = True + go_tc _ (ForAllTy {}) = True + go_tc _ _ = False 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 @@ -12,6 +12,7 @@ import GHC.Types.Var.Env ( TidyEnv ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate ) import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar ) +import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Utils.FV ( FV ) import Data.Bool ( Bool ) @@ -37,6 +38,6 @@ getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) +zonkSubs :: TidyEnv -> [HoleFit] -> ZonkM (TidyEnv, [HoleFit]) sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit] diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -32,6 +32,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType +import GHC.Tc.Zonk.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr @@ -43,7 +44,7 @@ import GHC.Types.Var.Set import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.SrcLoc import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) import GHC.Data.Maybe @@ -370,7 +371,7 @@ -- is on we must call tcSubType. -- Zonk app_res_rho first, because QL may have instantiated some -- delta variables to polytypes, and tcSubType doesn't expect that - do { app_res_rho <- zonkQuickLook do_ql app_res_rho + do { app_res_rho <- liftZonkM $ zonkQuickLook do_ql app_res_rho ; tcSubTypeDS rn_expr app_res_rho exp_res_ty } -- Typecheck the value arguments @@ -383,7 +384,7 @@ else do rebuildHsApps tc_fun fun_ctxt tc_args app_res_rho ; whenDOptM Opt_D_dump_tc_trace $ - do { inst_args <- mapM zonkArg inst_args -- Only when tracing + do { inst_args <- liftZonkM $ mapM zonkArg inst_args -- Only when tracing ; traceTc "tcApp }" (vcat [ text "rn_fun:" <+> ppr rn_fun , text "rn_args:" <+> ppr rn_args , text "inst_args" <+> brackets (pprWithCommas pprHsExprArgTc inst_args) @@ -410,7 +411,7 @@ -- See Note [Quick Look for particular Ids] quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey] -zonkQuickLook :: Bool -> TcType -> TcM TcType +zonkQuickLook :: Bool -> TcType -> ZonkM TcType -- After all Quick Look unifications are done, zonk to ensure that all -- instantiation variables are substituted away -- @@ -427,7 +428,7 @@ -- zonkArg is used *only* during debug-tracing, to make it easier to -- see what is going on. For that reason, it is not a full zonk: add -- more if you need it. -zonkArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst) +zonkArg :: HsExprArg 'TcpInst -> ZonkM (HsExprArg 'TcpInst) zonkArg eva@(EValArg { eva_arg_ty = Scaled m ty }) = do { ty' <- zonkTcType ty ; return (eva { eva_arg_ty = Scaled m ty' }) } @@ -459,7 +460,7 @@ -- Then Theta = [p :-> forall a. a->a], and we want -- to check 'e' with expected type (forall a. a->a) -- See Note [Instantiation variables are short lived] - arg_ty <- zonkQuickLook do_ql arg_ty + arg_ty <- liftZonkM $ zonkQuickLook do_ql arg_ty -- Now check the argument ; arg' <- tcScalingUsage mult $ @@ -543,25 +544,16 @@ HsUnboundVar {} -> True _ -> False - inst_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool - inst_all (Invisible {}) = True - inst_all Required = False - - inst_inferred (Invisible InferredSpec) = True - inst_inferred (Invisible SpecifiedSpec) = False - inst_inferred Required = False - - inst_none _ = False - inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool - inst_fun [] | inst_final = inst_all - | otherwise = inst_none - -- Using `inst_none` for `:type` avoids + -- True <=> instantiate a tyvar with this ForAllTyFlag + inst_fun [] | inst_final = isInvisibleForAllTyFlag + | otherwise = const False + -- Using `const False` for `:type` avoids -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b` -- turning into `forall a {r2} (b :: TYPE r2). a -> b`. -- See #21088. - inst_fun (EValArg {} : _) = inst_all - inst_fun _ = inst_inferred + inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag + inst_fun _ = isInferredForAllTyFlag ----------- go, go1 :: Delta @@ -588,7 +580,12 @@ -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate go1 delta acc so_far fun_ty args | (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty - , (theta, body2) <- tcSplitPhiTy body1 + , (theta, body2) <- if inst_fun args Inferred + then tcSplitPhiTy body1 + else ([], body1) + -- inst_fun args Inferred: dictionary parameters are like Inferred foralls + -- E.g. #22908: f :: Foo => blah + -- No foralls! But if inst_final=False, don't instantiate , not (null tvs && null theta) = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $ instantiateSigma fun_orig tvs theta body2 @@ -656,7 +653,7 @@ -- Suppose kappa :: kk -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk -- co_wrap :: (fun_ty' |> kind_co) ~ fun_ty' - ; writeMetaTyVar kappa (mkCastTy fun_ty' kind_co) + ; liftZonkM $ writeMetaTyVar kappa (mkCastTy fun_ty' kind_co) -- kappa is uninstantiated ('go' already checked that) ; go delta' acc' so_far fun_ty' args } @@ -723,7 +720,7 @@ kind = tyVarKind tv ; ty_arg <- tcHsTypeApp hs_ty kind - ; inner_ty <- zonkTcType inner_ty + ; inner_ty <- liftZonkM $ zonkTcType inner_ty -- See Note [Visible type application zonk] ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg]) @@ -739,7 +736,7 @@ ; return (ty_arg, insted_ty) } | otherwise - = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty + = do { (_, fun_ty) <- liftZonkM $ zonkTidyTcType emptyTidyEnv fun_ty ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty } {- Note [Required quantifiers in the type of a term] @@ -953,7 +950,7 @@ ; return app_res_rho } quickLookResultType _ app_res_rho (Infer {}) - = zonkTcType app_res_rho + = liftZonkM $ zonkTcType app_res_rho -- Zonk the result type, to ensure that we substitute out any -- filled-in instantiation variable before calling -- unifyExpectedType. In the Check case, this isn't necessary, @@ -1037,7 +1034,7 @@ do { info <- readMetaTyVar kappa ; case info of Indirect ty1 -> go bvs ty1 ty2 - Flexi -> do { ty2 <- zonkTcType ty2 + Flexi -> do { ty2 <- liftZonkM $ zonkTcType ty2 ; go_flexi bvs kappa ty2 } } ---------------- @@ -1057,7 +1054,7 @@ vcat [ hang (ppr kappa <+> dcolon <+> ppr kappa_kind) 2 (text ":=" <+> ppr ty2 <+> dcolon <+> ppr ty2_kind) , text "co:" <+> ppr co ] - ; writeMetaTyVar kappa (mkCastTy ty2 co) } + ; liftZonkM $ writeMetaTyVar kappa (mkCastTy ty2 co) } | otherwise = return () -- Occurs-check or forall-bound variable @@ -1086,7 +1083,7 @@ calling unifyKind, producing a coercion perhaps emitting some deferred equality constraints. That is /different/ from the approach we use in the main constraint solver for heterogeneous equalities; see Note - [Equalities with incompatible kinds] in Solver.Canonical + [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality Why different? Because: - We can't use qlUnify to solve the kind constraint because qlUnify @@ -1196,7 +1193,7 @@ -- See Note [tagToEnum#] Urgh! tcTagToEnum tc_fun fun_ctxt tc_args res_ty | [val_arg] <- dropWhile (not . isHsValArg) tc_args - = do { res_ty <- zonkTcType res_ty + = do { res_ty <- liftZonkM $ zonkTcType res_ty -- Check that the type is algebraic ; case tcSplitTyConApp_maybe res_ty of { @@ -1226,7 +1223,8 @@ vanilla_result = rebuildHsApps tc_fun fun_ctxt tc_args res_ty check_enumeration ty' tc - | -- isTypeDataTyCon: see Note [Type data declarations] in GHC.Rename.Module + | -- isTypeDataTyCon: see wrinkle (W1) in + -- Note [Type data declarations] in GHC.Rename.Module isTypeDataTyCon tc = addErrTc (TcRnTagToEnumResTyTypeData ty') | isEnumerationTyCon tc = return () | otherwise = addErrTc (TcRnTagToEnumResTyNotAnEnum 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 @@ -29,10 +29,12 @@ import GHC.Types.Tickish (CoreTickish, GenTickish (..)) import GHC.Types.CostCentre (mkUserCC, mkDeclCCFlavour) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Hs +import GHC.Rename.Bind ( rejectBootDecls ) + import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) @@ -50,8 +52,9 @@ import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Tc.Utils.TcType import GHC.Tc.Validity (checkValidType, checkEscapingKind) +import GHC.Tc.Zonk.TcType -import GHC.Core.Predicate +import GHC.Core.Predicate ( getEqPredTys_maybe ) import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) @@ -72,6 +75,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env +import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Utils.Error @@ -231,9 +235,10 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type --- signatures in it. The renamer checked all this +-- signatures in it. The renamer checked all this. tcHsBootSigs binds sigs - = do { checkTc (null binds) TcRnIllegalHsBootFileDecl + = do { unless (null binds) $ + rejectBootDecls HsBoot BootBindsRn (concatMap (bagToList . snd) binds) ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames @@ -751,57 +756,103 @@ checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool -- True <=> apply the MR +-- See Note [When the MR applies] checkMonomorphismRestriction mbis lbinds - | null partial_sigs -- The normal case = do { mr_on <- xoptM LangExt.MonomorphismRestriction ; let mr_applies = mr_on && any (restricted . unLoc) lbinds - ; when mr_applies $ mapM_ checkOverloadedSig sigs + ; when mr_applies $ mapM_ checkOverloadedSig mbis ; return mr_applies } - - | otherwise -- See Note [Partial type signatures and the monomorphism restriction] - = return (all is_mono_psig partial_sigs) - where - sigs, partial_sigs :: [TcIdSigInst] - sigs = [sig | MBI { mbi_sig = Just sig } <- mbis] - partial_sigs = [sig | sig@(TISI { sig_inst_sig = PartialSig {} }) <- sigs] - - complete_sig_bndrs :: NameSet - complete_sig_bndrs - = mkNameSet [ idName bndr - | TISI { sig_inst_sig = CompleteSig { sig_bndr = bndr }} <- sigs ] + no_mr_bndrs :: NameSet + no_mr_bndrs = mkNameSet (mapMaybe no_mr_name mbis) - is_mono_psig (TISI { sig_inst_theta = theta, sig_inst_wcx = mb_extra_constraints }) - = null theta && isNothing mb_extra_constraints + no_mr_name :: MonoBindInfo -> Maybe Name + -- Just n for binders that have a signature that says "no MR needed for me" + no_mr_name (MBI { mbi_sig = Just sig }) + | TISI { sig_inst_sig = info, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig + = case info of + CompleteSig { sig_bndr = bndr } -> Just (idName bndr) + PartialSig { psig_name = nm } + | null theta, isNothing wcx -> Nothing -- f :: _ -> _ + | otherwise -> Just nm -- f :: Num a => a -> _ + -- For the latter case, we don't want the MR: + -- the user has explicitly specified a type-class context + no_mr_name _ = Nothing -- The Haskell 98 monomorphism restriction + restricted :: HsBindLR GhcRn GhcRn -> Bool restricted (PatBind {}) = True - restricted (VarBind { var_id = v }) = no_sig v restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m - && no_sig (unLoc v) - restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b) + && mr_needed_for (unLoc v) + restricted (VarBind { var_ext = x }) = dataConCantHappen x + restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b) restricted_match mg = matchGroupArity mg == 0 -- No args => like a pattern binding -- Some args => a function binding - no_sig nm = not (nm `elemNameSet` complete_sig_bndrs) + mr_needed_for nm = not (nm `elemNameSet` no_mr_bndrs) -checkOverloadedSig :: TcIdSigInst -> TcM () +checkOverloadedSig :: MonoBindInfo -> TcM () -- Example: -- f :: Eq a => a -> a -- K f = e -- The MR applies, but the signature is overloaded, and it's -- best to complain about this directly -- c.f #11339 -checkOverloadedSig sig - | not (null (sig_inst_theta sig)) - , let orig_sig = sig_inst_sig sig +checkOverloadedSig (MBI { mbi_sig = mb_sig }) + | Just (TISI { sig_inst_sig = orig_sig, sig_inst_theta = theta, sig_inst_wcx = wcx }) <- mb_sig + , not (null theta && isNothing wcx) = setSrcSpan (sig_loc orig_sig) $ failWith $ TcRnOverloadedSig orig_sig | otherwise = return () +{- Note [When the MR applies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Monomorphism Restriction (MR) applies as specifies in the Haskell Report: + +* If -XMonomorphismRestriction is on, and +* Any binding is restricted + +A binding is restricted if: +* It is a pattern binding e.g. (x,y) = e +* Or it is a FunBind with no arguments e.g. f = rhs + and the binder `f` lacks a No-MR signature + +A binder f has a No-MR signature if + +* It has a complete type signature + e.g. f :: Num a => a -> a + +* Or it has a /partial/ type signature with a /context/ + e.g. f :: (_) => a -> _ + g :: Num a => a -> _ + h :: (Num a, _) => a -> _ + All of f,g,h have a No-MR signature. They say that the function is overloaded + so it's silly to try to apply the MR. This means that #19106 works out + fine. Ditto #11016, which looked like + f4 :: (?loc :: Int) => _ + f4 = ?loc + + This partial-signature stuff is a bit ad-hoc but seems to match our + use-cases. See also Note [Constraints in partial type signatures] + in GHC.Tc.Solver. + +Example: the MR does apply to + k :: _ -> _ + k = rhs +because k's binding has no arguments, and `k` does not have +a No-MR signature. + +All of this checking takes place after synonym expansion. For example: + type Wombat a = forall b. Eq [b] => ...b...a... + f5 :: Wombat _ +This (and does) behave just like + f5 :: forall b. Eq [b] => ...b..._... + +-} + -------------- mkExport :: TcPragEnv -> WantedConstraints -- residual constraints, already emitted (for errors only) @@ -827,7 +878,7 @@ (MBI { mbi_poly_name = poly_name , mbi_sig = mb_sig , mbi_mono_id = mono_id }) - = do { mono_ty <- zonkTcType (idType mono_id) + = do { mono_ty <- liftZonkM $ zonkTcType (idType mono_id) ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty -- NB: poly_id has a zonked type @@ -850,15 +901,9 @@ then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int - else tcSubTypeSigma GhcBug20076 + else tcSubTypeSigma (ImpedanceMatching poly_id) sig_ctxt sel_poly_ty poly_ty - -- as Note [Impedance matching] explains, this should never fail, - -- and thus we'll never see an error message. It *may* do - -- instantiation, but no message will ever be printed to the - -- user, and so we use Shouldn'tHappenOrigin. - -- Actually, there is a bug here: #20076. So we tell the user - -- that they hit the bug. Once #20076 is fixed, change this - -- back to Shouldn'tHappenOrigin. + -- See Note [Impedance matching] ; localSigWarn poly_id mb_sig @@ -903,15 +948,19 @@ ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' - , ppr inferred_poly_ty]) + , ppr inferred_poly_ty + , text "insoluble" <+> ppr insoluble ]) + ; unless insoluble $ addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ do { checkEscapingKind inferred_poly_ty + -- See Note [Inferred type with escaping kind] ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty } - -- See Note [Validity of inferred types] - -- If we found an insoluble error in the function definition, don't - -- do this check; otherwise (#14000) we may report an ambiguity - -- error for a rather bogus type. + -- See Note [Validity of inferred types] + -- unless insoluble: if we found an insoluble error in the + -- function definition, don't do this check; otherwise + -- (#14000) we may report an ambiguity error for a rather + -- bogus type. ; return (mkLocalId poly_name ManyTy inferred_poly_ty) } @@ -940,7 +989,7 @@ , sig_inst_skols = annotated_tvs })) = -- Choose quantifiers for a partial type signature do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs - ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs + ; psig_qtv_bndrs <- liftZonkM $ mapM zonkInvisTVBinder psig_qtv_bndrs ; let psig_qtvs = map binderVar psig_qtv_bndrs psig_qtv_set = mkVarSet psig_qtvs psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs @@ -959,7 +1008,7 @@ ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs , not (tv `elem` qtvs) ] - ; annotated_theta <- zonkTcTypes annotated_theta + ; annotated_theta <- liftZonkM $ zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx -- NB: free_tvs includes tau_tvs @@ -1019,7 +1068,8 @@ -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. -- So, to make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta + Just (wc_var, wc_co) -> liftZonkM $ + writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta `mkCastTy` mkSymCo wc_co) Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) @@ -1052,7 +1102,7 @@ chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) })) = pprPanic "chooseInferredQuantifiers" (ppr sig) -mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) +mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty ; let msg = vcat [ text "When checking the inferred type" @@ -1068,7 +1118,7 @@ warnMissingSignatures :: Id -> TcM () warnMissingSignatures id - = do { env0 <- tcInitTidyEnv + = do { env0 <- liftZonkM $ tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty ; addDiagnosticTcM (env1, dia) } @@ -1098,33 +1148,6 @@ doesn't seem much point. Indeed, adding a partial type signature is a way to get per-binding inferred generalisation. -Note [Partial type signatures and the monomorphism restriction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We apply the MR if /none/ of the partial signatures has a context. e.g. - f :: _ -> Int - f x = rhs -The partial type signature says, in effect, "there is no context", which -amounts to appplying the MR. Indeed, saying - f :: _ - f = rhs -is a way for forcing the MR to apply. - -But we /don't/ want to apply the MR if the partial signatures do have -a context e.g. (#11016): - f2 :: (?loc :: Int) => _ - f2 = ?loc -It's stupid to apply the MR here. This test includes an extra-constraints -wildcard; that is, we don't apply the MR if you write - f3 :: _ => blah - -But watch out. We don't want to apply the MR to - type Wombat a = forall b. Eq b => ...b...a... - f4 :: Wombat _ -Here f4 doesn't /look/ as if it has top-level overloading, but in fact it -does, hidden under Wombat. We can't "see" that because we only have access -to the HsType at the moment. That's why we do the check in -checkMonomorphismRestriction. - Note [Quantified variables in partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1224,11 +1247,9 @@ forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype and the proof is the impedance matcher. -Notice that the impedance matcher may do defaulting. See #7173. - -If we've gotten the constraints right during inference (and we assume we have), -this sub-type check should never fail. It's not really a check -- it's more of -a procedure to produce the right wrapper. +The impedance matcher can do defaulting: in the above example, we default +to Integer because of Num. See #7173. If we're dealing with a nondefaultable +class, impedance matching can fail. See #23427. Note [SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1492,8 +1513,10 @@ Just (TcIdSig sig) -> Right (name, sig) _ -> Left name -tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) - -- AbsBind, VarBind impossible +tcLhs _ _ b@(PatSynBind {}) = pprPanic "tcLhs: PatSynBind" (ppr b) + -- pattern synonyms are handled separately; see tc_single + +tcLhs _ _ (VarBind { var_ext = x }) = dataConCantHappen x lookupMBI :: Name -> TcM MonoBindInfo -- After typechecking the pattern, look up the binder diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -19,7 +19,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Tc.Solver import GHC.Tc.Validity import GHC.Tc.Utils.TcType diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -2,24 +2,28 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} -module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where +module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where import GHC.Prelude import GHC.Hs -import GHC.Types.FieldLabel import GHC.Builtin.Names import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env + ( TyThing(AConLike, AnId), tcLookupGlobal, tcLookupTyCon ) import GHC.Tc.Utils.TcType +import GHC.Rename.Doc +import GHC.Rename.Module import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Utils.Error import GHC.Unit.Module import GHC.Unit.Module.Imported +import GHC.Unit.Module.Warnings import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic @@ -28,8 +32,11 @@ import GHC.Data.Maybe import GHC.Data.FastString (fsLit) import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Unique.Set +import GHC.Types.Unique.Map import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Env @@ -40,11 +47,11 @@ import GHC.Types.Id.Info import GHC.Types.Name.Reader -import Control.Monad -import GHC.Driver.Session -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) -import GHC.Rename.Doc +import Control.Arrow ( first ) +import Control.Monad ( when ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) +import Data.List ( sortBy ) {- ************************************************************************ @@ -130,24 +137,36 @@ data ExportAccum -- The type of the accumulating parameter of -- the main worker function in rnExports - = ExportAccum - ExportOccMap -- Tracks exported occurrence names - (UniqSet ModuleName) -- Tracks (re-)exported module names + = ExportAccum { + expacc_exp_occs :: ExportOccMap, + -- ^ Tracks exported occurrence names + expacc_mods :: UniqMap ModuleName [Name], + -- ^ Tracks (re-)exported module names + -- and the names they re-export + expacc_warn_spans :: ExportWarnSpanNames, + -- ^ Information about warnings for names + expacc_dont_warn :: DontWarnExportNames + -- ^ What names not to export warnings for + -- (because they are exported without a warning) + } + emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet +emptyExportAccum = ExportAccum emptyOccEnv emptyUniqMap [] emptyNameEnv -accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y))) +accumExports :: (ExportAccum -> x -> TcRn (ExportAccum, Maybe y)) -> [x] - -> TcRn [y] -accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum - where f' acc x = do - m <- attemptM (f acc x) - pure $ case m of - Just (Just (acc', y)) -> (acc', Just y) - _ -> (acc, Nothing) + -> TcRn ([y], ExportWarnSpanNames, DontWarnExportNames) +accumExports f xs = do + (ExportAccum _ _ export_warn_spans dont_warn_export, ys) + <- mapAccumLM f' emptyExportAccum xs + return ( catMaybes ys + , export_warn_spans + , dont_warn_export ) + where f' acc x + = fromMaybe (acc, Nothing) <$> attemptM (f acc x) -type ExportOccMap = OccEnv (GreName, IE GhcPs) +type ExportOccMap = OccEnv (Name, IE GhcPs) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things @@ -164,16 +183,13 @@ rnExports explicit_mod exports = checkNoErrs $ -- Fail if anything in rnExports finds -- an error fails, to avoid error cascade - unsetWOptM Opt_WarnWarningsDeprecations $ - -- Do not report deprecations arising from the export - -- list, to avoid bleating about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) do { hsc_env <- getTopEnv ; tcg_env <- getGblEnv ; let dflags = hsc_dflags hsc_env TcGblEnv { tcg_mod = this_mod , tcg_rdr_env = rdr_env , tcg_imports = imports + , tcg_warns = warns , tcg_src = hsc_src } = tcg_env default_main | mainModIs (hsc_HUE hsc_env) == this_mod , Just main_fun <- mainFunIs dflags @@ -189,7 +205,7 @@ ; let real_exports | explicit_mod = exports | has_main - = Just (noLocA [noLocA (IEVar noExtField + = Just (noLocA [noLocA (IEVar Nothing (noLocA (IEName noExtField $ noLocA default_main)))]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope @@ -197,7 +213,7 @@ -- Rename the export list ; let do_it = exports_from_avail real_exports rdr_env imports this_mod - ; (rn_exports, final_avails) + ; (rn_exports, final_avails, new_export_warns) <- if hsc_src == HsigFile then do (mb_r, msgs) <- tryTc do_it case mb_r of @@ -206,7 +222,7 @@ else checkNoErrs do_it -- Final processing - ; let final_ns = availsToNameSetWithSelectors final_avails + ; let final_ns = availsToNameSet final_avails ; traceRn "rnExports: Exports:" (ppr final_avails) @@ -215,8 +231,18 @@ Nothing -> Nothing Just _ -> rn_exports , tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly final_ns }) } + usesOnly final_ns + , tcg_warns = insertWarnExports + warns new_export_warns}) } +-- | List of names and the information about their warnings +-- (warning, export list item span) +type ExportWarnSpanNames = [(Name, WarningTxt GhcRn, SrcSpan)] + +-- | Map from names that should not have export warnings to +-- the spans of export list items that are missing those warnings +type DontWarnExportNames = NameEnv (NE.NonEmpty SrcSpan) + exports_from_avail :: Maybe (LocatedL [LIE GhcPs]) -- ^ 'Nothing' means no explicit export list -> GlobalRdrEnv @@ -225,8 +251,8 @@ -- @module Foo@ export is valid (it's not valid -- if we didn't import @Foo@!) -> Module - -> RnM (Maybe [(LIE GhcRn, Avails)], Avails) - -- (Nothing, _) <=> no explicit export list + -> RnM (Maybe [(LIE GhcRn, Avails)], Avails, ExportWarnNames GhcRn) + -- (Nothing, _, _) <=> no explicit export list -- if explicit export list is present it contains -- each renamed export item together with its exported -- names. @@ -241,7 +267,7 @@ ; let avails = map fix_faminst . gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ rdr_env - ; return (Nothing, avails) } + ; return (Nothing, avails, []) } where -- #11164: when we define a data instance -- but not data family, re-export the family @@ -249,18 +275,22 @@ -- only data families can locally define subordinate things (`ns` here) -- without locally defining (and instead importing) the parent (`n`) fix_faminst avail@(AvailTC n ns) - | availExportsDecl avail = avail - | otherwise = AvailTC n (NormalGreName n:ns) + | availExportsDecl avail + = avail + | otherwise + = AvailTC n (n:ns) fix_faminst avail = avail exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do ie_avails <- accumExports do_litem rdr_items + = do (ie_avails, export_warn_spans, dont_warn_export) + <- accumExports do_litem rdr_items let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families - return (Just ie_avails, final_exports) + export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export + return (Just ie_avails, final_exports, export_warn_names) where do_litem :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) + -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails)) do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie) -- Maps a parent to its in-scope children @@ -270,151 +300,324 @@ -- See Note [Avails of associated data families] expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] expand_tyty_gre (gre@GRE { gre_par = ParentIs p }) - | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }] - expand_tyty_gre gre = [gre] + | isTyConName p + , isTyConName (greName gre) + = [gre, gre{ gre_par = NoParent }] + expand_tyty_gre gre + = [gre] imported_modules = [ imv_name imv | xs <- moduleEnvElts $ imp_mods imports , imv <- importedByUser xs ] exports_from_item :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - exports_from_item (ExportAccum occs earlier_mods) - (L loc ie@(IEModuleContents _ lmod@(L _ mod))) - | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { addDiagnostic (TcRnDupeModuleExport mod) ; - return Nothing } + -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails)) + exports_from_item expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_mods = earlier_mods, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEModuleContents (warn_txt_ps, _) lmod@(L _ mod))) + | Just exported_names <- lookupUniqMap earlier_mods mod -- Duplicate export of M + = do { addDiagnostic (TcRnDupeModuleExport mod) + ; (export_warn_spans', dont_warn_export', _) <- + process_warning export_warn_spans + dont_warn_export + exported_names + warn_txt_ps + (locA loc) + -- Checks if all the names are exported with the same warning message + -- or if they should not be warned about + ; return ( expacc{ expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , Nothing ) } - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = [ availFromGRE gre' - | (gre, _) <- gre_prs - , gre' <- expand_tyty_gre gre ] - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - ; mods = addOneToUniqSet earlier_mods mod - } + | otherwise + = do { let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + ; new_gres = [ gre' + | (gre, _) <- gre_prs + , gre' <- expand_tyty_gre gre ] + ; new_exports = map availFromGRE new_gres + ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs + ; exported_names = map greName new_gres + ; mods = addToUniqMap earlier_mods mod exported_names + } - ; checkErr exportValid (TcRnExportedModNotImported mod) - ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) + ; checkErr exportValid (TcRnExportedModNotImported mod) + ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs all_gres + ; traceRn "efa" (ppr mod $$ ppr all_gres) + ; addUsedGREs ExportDeprecationWarnings all_gres - ; occs' <- check_occs ie occs new_exports - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn "export_mod" - (vcat [ ppr mod - , ppr new_exports ]) + ; occs' <- check_occs occs ie new_gres + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; (export_warn_spans', dont_warn_export', warn_txt_rn) <- + process_warning export_warn_spans + dont_warn_export + exported_names + warn_txt_ps + (locA loc) - ; return (Just ( ExportAccum occs' mods - , ( L loc (IEModuleContents noExtField lmod) - , new_exports))) } + ; traceRn "export_mod" + (vcat [ ppr mod + , ppr new_exports ]) + ; return ( ExportAccum { expacc_exp_occs = occs' + , expacc_mods = mods + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , Just (L loc (IEModuleContents warn_txt_rn lmod), new_exports) ) } - exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do - m_new_ie <- lookup_doc_ie ie - case m_new_ie of - Just new_ie -> return (Just (acc, (L loc new_ie, []))) + exports_from_item acc lie = do + m_doc_ie <- lookup_doc_ie lie + case m_doc_ie of + Just new_ie -> return (acc, Just (new_ie, [])) Nothing -> do - (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return Nothing -- Avoid error cascade - else do + m_ie <- lookup_ie acc lie + case m_ie of + Nothing -> return (acc, Nothing) + Just (acc', new_ie, avail) + -> return (acc', Just (new_ie, [avail])) - occs' <- check_occs ie occs [avail] + ------------- + lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, AvailInfo)) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEVar warn_txt_ps l)) + = do mb_gre <- lookupGreAvailRn $ lieWrappedName l + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre - return (Just ( ExportAccum occs' mods - , (L loc new_ie, [avail]))) + occs' <- check_occs occs ie [gre] + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + [name] + warn_txt_ps + (locA loc) - ------------- - lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEVar warn_txt_rn (replaceLWrappedName l name)) + , avail ) - lookup_ie (IEThingAbs _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noAnn (L l (replaceWrappedName rdr name)) - , avail) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingAbs (warn_txt_ps, ann) l)) + = do mb_gre <- lookupGreAvailRn $ lieWrappedName l + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre - lookup_ie ie@(IEThingAll _ n') - = do - (n, avail, flds) <- lookup_ie_all ie n' - let name = unLoc n - return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n)) - , availTC name (name:avail) flds) + occs' <- check_occs occs ie [gre] + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + [name] + warn_txt_ps + (locA loc) + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEThingAbs (warn_txt_rn, ann) (replaceLWrappedName l name)) + , avail ) - lookup_ie ie@(IEThingWith _ l wc sub_rdrs) - = do - (lname, subs, avails, flds) - <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, all_avail, all_flds) <- - case wc of - NoIEWildcard -> return (lname, [], []) - IEWildcard _ -> lookup_ie_all ie l - let name = unLoc lname - let flds' = flds ++ (map noLoc all_flds) - return (IEThingWith flds' (replaceLWrappedName l name) wc subs, - availTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingAll (warn_txt_ps, ann) l)) + = do mb_gre <- lookupGreAvailRn $ lieWrappedName l + for mb_gre $ \ par -> do + all_kids <- lookup_ie_kids_all ie l par + let name = greName par + all_gres = par : all_kids + all_names = map greName all_gres + occs' <- check_occs occs ie all_gres + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + all_names + warn_txt_ps + (locA loc) - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name)) + , AvailTC name all_names ) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs)) + = do mb_gre <- addExportErrCtxt ie + $ lookupGreAvailRn $ lieWrappedName l + for mb_gre $ \ par -> do + (subs, with_kids) + <- addExportErrCtxt ie + $ lookup_ie_kids_with par sub_rdrs - lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs] - -> RnM (Located Name, [LIEWrappedName GhcRn], [Name], - [Located FieldLabel]) - lookup_ie_with (L l rdr) sub_rdrs - = do name <- lookupGlobalOccRn $ ieWrappedName rdr - (non_flds, flds) <- lookupChildrenExport name sub_rdrs - if isUnboundName name - then return (L (locA l) name, [], [name], []) - else return (L (locA l) name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) + wc_kids <- + case wc of + NoIEWildcard -> return [] + IEWildcard _ -> lookup_ie_kids_all ie l par - lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs - -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (L l rdr) = - do name <- lookupGlobalOccRn $ ieWrappedName rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids (ieWrappedName rdr) gres - when (null gres) $ - if isTyConName name - then addTcRnDiagnostic (TcRnDodgyExports name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (TcRnExportHiddenComponents ie) - return (L (locA l) name, non_flds, flds) + let name = greName par + all_kids = with_kids ++ wc_kids + all_gres = par : all_kids + all_names = map greName all_gres + occs' <- check_occs occs ie all_gres + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + all_names + warn_txt_ps + (locA loc) + + return ( expacc{ expacc_exp_occs = occs' + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , L loc (IEThingWith (warn_txt_rn, ann) (replaceLWrappedName l name) wc subs) + , AvailTC name all_names ) + + lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier + + + lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs] + -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt]) + lookup_ie_kids_with gre sub_rdrs = + do { let name = greName gre + ; kids <- lookupChildrenExport name sub_rdrs + ; return (map fst kids, map snd kids) } + + lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt + -> RnM [GlobalRdrElt] + lookup_ie_kids_all ie (L _ rdr) gre = + do { let name = greName gre + gres = findChildren kids_env name + ; addUsedKids (ieWrappedName rdr) gres + ; when (null gres) $ + if isTyConName name + then addTcRnDiagnostic (TcRnDodgyExports gre) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (TcRnExportHiddenComponents ie) + ; return gres } + ------------- - lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn)) - lookup_doc_ie (IEGroup _ lev doc) = do + + rn_warning_txt_loc :: LocatedP (WarningTxt GhcPs) -> RnM (LocatedP (WarningTxt GhcRn)) + rn_warning_txt_loc (L loc warn_txt) = L loc <$> rnWarningTxt warn_txt + + -- Runs for every Name + -- - If there is no new warning, flags that the old warning should not be + -- included (since a warning should only be emitted if all + -- of the export statements have a warning) + -- - If the Name already has a warning, adds it + process_warning :: ExportWarnSpanNames -- Old aggregate data about warnins + -> DontWarnExportNames -- Old names not to warn about + -> [Name] -- Names to warn about + -> Maybe (LocatedP (WarningTxt GhcPs)) -- Warning + -> SrcSpan -- Span of the export list item + -> RnM (ExportWarnSpanNames, -- Aggregate data about the warnings + DontWarnExportNames, -- Names not to warn about in the end + -- (when there was a non-warned export) + Maybe (LocatedP (WarningTxt GhcRn))) -- Renamed warning + process_warning export_warn_spans + dont_warn_export + names Nothing loc + = return ( export_warn_spans + , foldr update_dont_warn_export + dont_warn_export names + , Nothing ) + where + update_dont_warn_export :: Name -> DontWarnExportNames -> DontWarnExportNames + update_dont_warn_export name dont_warn_export' + = extendNameEnv_Acc (NE.<|) + NE.singleton + dont_warn_export' + name + loc + + process_warning export_warn_spans + dont_warn_export + names (Just warn_txt_ps) loc + = do + warn_txt_rn <- rn_warning_txt_loc warn_txt_ps + let new_export_warn_spans = map (, unLoc warn_txt_rn, loc) names + return ( new_export_warn_spans ++ export_warn_spans + , dont_warn_export + , Just warn_txt_rn ) + + -- For each name exported with any warnings throws an error + -- if there are any exports of that name with a different warning + aggregate_warnings :: ExportWarnSpanNames + -> DontWarnExportNames + -> RnM (ExportWarnNames GhcRn) + aggregate_warnings export_warn_spans dont_warn_export + = fmap catMaybes + $ mapM (aggregate_single . extract_name) + $ NE.groupBy (\(n1, _, _) (n2, _, _) -> n1 == n2) + $ sortBy (\(n1, _, _) (n2, _, _) -> n1 `compare` n2) export_warn_spans + where + extract_name :: NE.NonEmpty (Name, WarningTxt GhcRn, SrcSpan) + -> (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan)) + extract_name l@((name, _, _) NE.:| _) + = (name, NE.map (\(_, warn_txt, span) -> (warn_txt, span)) l) + + aggregate_single :: (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan)) + -> RnM (Maybe (Name, WarningTxt GhcRn)) + aggregate_single (name, (warn_txt_rn, loc) NE.:| warn_spans) + = do + -- Emit an error if the warnings differ + case NE.nonEmpty spans_different of + Nothing -> return () + Just spans_different + -> addErrAt loc (TcRnDifferentExportWarnings name spans_different) + -- Emit a warning if some export list items do not have a warning + case lookupNameEnv dont_warn_export name of + Nothing -> return $ Just (name, warn_txt_rn) + Just not_warned_spans -> do + addDiagnosticAt loc (TcRnIncompleteExportWarnings name not_warned_spans) + return Nothing + where + spans_different = map snd $ filter (not . warningTxtSame warn_txt_rn . fst) warn_spans + + ------------- + lookup_doc_ie :: LIE GhcPs -> RnM (Maybe (LIE GhcRn)) + lookup_doc_ie (L loc (IEGroup _ lev doc)) = do doc' <- rnLHsDoc doc - pure $ Just (IEGroup noExtField lev doc') - lookup_doc_ie (IEDoc _ doc) = do + pure $ Just (L loc (IEGroup noExtField lev doc')) + lookup_doc_ie (L loc (IEDoc _ doc)) = do doc' <- rnLHsDoc doc - pure $ Just (IEDoc noExtField doc') - lookup_doc_ie (IEDocNamed _ str) = pure $ Just (IEDocNamed noExtField str) + pure $ Just (L loc (IEDoc noExtField doc')) + lookup_doc_ie (L loc (IEDocNamed _ str)) + = pure $ Just (L loc (IEDocNamed noExtField str)) lookup_doc_ie _ = pure Nothing -- In an export item M.T(A,B,C), we want to treat the uses of -- A,B,C as if they were M.A, M.B, M.C -- Happily pickGREs does just the right thing addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () - addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) - -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionGreNames . map gre_name + addUsedKids parent_rdr kid_gres + = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) -- Renaming and typechecking of exports happens after everything else has -- been typechecked. @@ -477,49 +680,45 @@ lookupChildrenExport :: Name -> [LIEWrappedName GhcPs] - -> RnM ([LIEWrappedName GhcRn], [Located FieldLabel]) -lookupChildrenExport spec_parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs + -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) +lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items where - -- Pick out the possible namespaces in order of priority - -- This is a consequence of how the parser parses all - -- data constructors as type constructors. - choosePossibleNamespaces :: NameSpace -> [NameSpace] - choosePossibleNamespaces ns - | ns == varName = [varName, tcName] - | ns == tcName = [dataName, tcName] - | otherwise = [ns] -- Process an individual child doOne :: LIEWrappedName GhcPs - -> RnM (Either (LIEWrappedName GhcRn) (Located FieldLabel)) + -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) doOne n = do let bareName = (ieWrappedName . unLoc) n - lkup v = lookupSubBndrOcc_helper False True - spec_parent (setRdrNameSpace bareName v) + what_lkup :: LookupChild + what_lkup = + LookupChild + { wantedParent = spec_parent + , lookupDataConFirst = True + , prioritiseParent = False -- See T11970. + } - name <- combineChildLookupResult $ map lkup $ - choosePossibleNamespaces (rdrNameSpace bareName) + -- Do not report export list declaration deprecations + name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings + spec_parent bareName what_lkup traceRn "lookupChildrenExport" (ppr name) -- Default to data constructors for slightly better error -- messages let unboundName :: RdrName unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName + then bareName + else setRdrNameSpace bareName dataName case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (L l (IEName noExtField (L (la2na l) ub))))} - FoundChild par child -> do { checkPatSynParent spec_parent par child - ; return $ case child of - FieldGreName fl -> Right (L (getLocA n) fl) - NormalGreName name -> Left (replaceLWrappedName n name) - } - IncorrectParent p c gs -> failWithDcErr p c gs + NameNotFound -> + do { ub <- reportUnboundName unboundName + ; let l = getLoc n + gre = mkLocalGRE UnboundGRE NoParent ub + ; return (L l (IEName noExtField (L (la2na l) ub)), gre)} + FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> + do { checkPatSynParent spec_parent par child_nm + ; return (replaceLWrappedName n child_nm, child) + } + IncorrectParent p c gs -> failWithDcErr p (greName c) gs -- Note [Typing Pattern Synonym Exports] @@ -582,30 +781,31 @@ checkPatSynParent :: Name -- ^ Alleged parent type constructor -- User wrote T( P, Q ) -> Parent -- The parent of P we discovered - -> GreName -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector + -> Name + -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector -> TcM () -- Fails if wrong parent checkPatSynParent _ (ParentIs {}) _ = return () -checkPatSynParent parent NoParent gname +checkPatSynParent parent NoParent nm | isUnboundName parent -- Avoid an error cascade = return () | otherwise - = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname) + = do { parent_ty_con <- tcLookupTyCon parent + ; mpat_syn_thing <- tcLookupGlobal nm -- 1. Check that the Id was actually from a thing associated with patsyns ; case mpat_syn_thing of AnId i | isId i , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr gname) parent_ty_con p + -> handle_pat_syn (selErr nm) parent_ty_con p AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p - _ -> failWithDcErr parent gname [] } + _ -> failWithDcErr parent nm [] } where psErr = exportErrCtxt "pattern synonym" selErr = exportErrCtxt "pattern synonym record selector" @@ -641,73 +841,66 @@ {-===========================================================================-} -check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] - -> RnM ExportOccMap -check_occs ie occs avails - -- 'avails' are the entities specified by 'ie' - = foldlM check occs children + +-- | Insert the given 'GlobalRdrElt's into the 'ExportOccMap', checking that +-- each of the given 'GlobalRdrElt's does not appear multiple times in +-- the 'ExportOccMap', as per Note [Exporting duplicate declarations]. +check_occs :: ExportOccMap -> IE GhcPs -> [GlobalRdrElt] -> RnM ExportOccMap +check_occs occs ie gres + -- 'gres' are the entities specified by 'ie' + = do { drf <- xoptM LangExt.DuplicateRecordFields + ; foldlM (check drf) occs gres } where - children = concatMap availGreNames avails -- Check for distinct children exported with the same OccName (an error) or -- for duplicate exports of the same child (a warning). - check :: ExportOccMap -> GreName -> RnM ExportOccMap - check occs child - = case try_insert occs child of - Right occs' -> return occs' + -- + -- See Note [Exporting duplicate declarations]. + check :: Bool -> ExportOccMap -> GlobalRdrElt -> RnM ExportOccMap + check drf_enabled occs gre + = case try_insert occs gre of + Right occs' + -- If DuplicateRecordFields is not enabled, also make sure + -- that we are not exporting two fields with the same occNameFS + -- under different namespaces. + -- + -- See Note [Exporting duplicate record fields]. + | drf_enabled || not (isFieldOcc child_occ) + -> return occs' + | otherwise + -> do { let flds = filter (\(_,ie') -> not $ dupFieldExport_ok ie ie') + $ lookupFieldsOccEnv occs (occNameFS child_occ) + ; case flds of { [] -> return occs'; clash1:clashes -> + do { addDuplicateFieldExportErr (gre,ie) (clash1 NE.:| clashes) + ; return occs } } } Left (child', ie') - | greNameMangledName child == greNameMangledName child' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie') + | child == child' -- Duplicate export of a single Name: a warning. + -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport gre ie ie') ; return occs } - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env child' child ie' ie) ; - return occs } + | otherwise -- Same OccName but different Name: an error. + -> do { global_env <- getGlobalRdrEnv + ; addErr (exportClashErr global_env child' child ie' ie) + ; return occs } + where + child = greName gre + child_occ = occName child -- Try to insert a child into the map, returning Left if there is something - -- already exported with the same OccName - try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap + -- already exported with the same OccName. + try_insert :: ExportOccMap -> GlobalRdrElt -> Either (Name, IE GhcPs) ExportOccMap try_insert occs child - = case lookupOccEnv occs name_occ of - Nothing -> Right (extendOccEnv occs name_occ (child, ie)) + = case lookupOccEnv occs occ of + Nothing -> Right (extendOccEnv occs occ (greName child, ie)) Just x -> Left x where - -- For fields, we check for export clashes using the (OccName of the) - -- selector Name - name_occ = nameOccName (greNameMangledName child) - + occ = greOccName child -dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool --- The GreName is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) --- --- Example of "yes" (#2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } +-- | Is it OK for the given name to be exported by both export items? -- --- Example of "yes" (#2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - +-- See Note [Exporting duplicate declarations]. +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool dupExport_ok child ie1 ie2 = not ( single ie1 || single ie2 || (explicit_in ie1 && explicit_in ie2) ) @@ -719,8 +912,7 @@ single IEVar {} = True single IEThingAbs {} = True - single _ = False - + single _ = False exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp = @@ -734,18 +926,18 @@ exportCtxt = text "In the export:" <+> ppr ie -failWithDcErr :: Name -> GreName -> [Name] -> TcM a +failWithDcErr :: Name -> Name -> [Name] -> TcM a failWithDcErr parent child parents = do - ty_thing <- tcLookupGlobal (greNameMangledName child) + ty_thing <- tcLookupGlobal child failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents exportClashErr :: GlobalRdrEnv - -> GreName -> GreName + -> Name -> Name -> IE GhcPs -> IE GhcPs -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2 - = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2' + = TcRnConflictingExports occ gre1' ie1' gre2' ie2' where occ = occName child1 -- get_gre finds a GRE for the Name, so that we can show its provenance @@ -753,9 +945,127 @@ gre2 = get_gre child2 get_gre child = fromMaybe (pprPanic "exportClashErr" (ppr child)) - (lookupGRE_GreName global_env child) - (child1', gre1', ie1', child2', gre2', ie2') = + (lookupGRE_Name global_env child) + (gre1', ie1', gre2', ie2') = case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of - LT -> (child1, gre1, ie1, child2, gre2, ie2) - GT -> (child2, gre2, ie2, child1, gre1, ie1) + LT -> (gre1, ie1, gre2, ie2) + GT -> (gre2, ie2, gre1, ie1) EQ -> panic "exportClashErr: clashing exports have identical location" + +addDuplicateFieldExportErr :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (Name, IE GhcPs) + -> RnM () +addDuplicateFieldExportErr gre others + = do { rdr_env <- getGlobalRdrEnv + ; let lkup = expectJust "addDuplicateFieldExportErr" . lookupGRE_Name rdr_env + other_gres = fmap (first lkup) others + ; addErr (TcRnDuplicateFieldExport gre other_gres) } + +-- | Is it OK to export two clashing duplicate record fields coming from the +-- given export items, with @-XDisambiguateRecordFields@ disabled? +-- +-- See Note [Exporting duplicate record fields]. +dupFieldExport_ok :: IE GhcPs -> IE GhcPs -> Bool +dupFieldExport_ok ie1 ie2 + | IEModuleContents {} <- ie1 + , ie2 == ie1 + = True + | otherwise + = False + +{- Note [Exporting duplicate declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to check that two different export items don't have both attempt to export +the same thing. What do we mean precisely? There are three main situations to consider: + + 1. We export two distinct Names with identical OccNames. This is an error. + 2. We export the same Name in two different export items. This is usually + a warning, but see below. + 3. We export a duplicate record field, and DuplicateRecordFields is not enabled. + See Note [Exporting duplicate record fields]. + +Concerning (2), we sometimes want to allow a duplicate export of a given Name, +as #4478 points out. The logic, as implemented in dupExport_ok, is that we +do not allow a given Name to be exported by two IEs iff either: + + - the Name is mentioned explicitly in both IEs, or + - one of the IEs mentions the name *alone*. + +Examples: + + NOT OK: module M( f, f ) + + f is mentioned explicitly in both + + NOT OK: module M( fmap, Functor(..) ) + NOT OK: module M( module Data.Functor, fmap ) + + One of the import items mentions fmap alone, which is also + exported by the other export item. + + OK: + module M( module A, module B ) where + import A( f ) + import B( f ) + + OK: (#2436) + module M( C(..), T(..) ) where + class C a where { data T a } + instance C Int where { data T Int = TInt } + + OK: (#2436) + module Foo ( T ) where + data family T a + module Bar ( T(..), module Foo ) where + import Foo + data instance T Int = TInt + +Note [Exporting duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields belonging to different datatypes belong to different namespaces, +as explained in Note [Record field namespacing] in GHC.Types.Name.Occurrence. +However, when the DuplicateRecordFields extension is NOT enabled, we want to +prevent users from exporting record fields that share the same underlying occNameFS. + +To enforce this, in check_occs, when inserting a new record field into the ExportOccMap +and DuplicateRecordFields is not enabled, we also look up any clashing record fields, +and report an error. + +Note however that the clash check has an extra wrinkle, similar to dupExport_ok, +as we want to allow the following: + + {-# LANGUAGE DuplicateRecordFields #-} + module M1 where + data D1 = MkD1 { foo :: Int } + data D2 = MkD2 { foo :: Bool } + + --------------------------------------------- + + module M2 ( module M1 ) where + import M1 + +That is, we should be allowed to re-export the whole module M1, without reporting +any nameclashes, even though M1 exports duplicate record fields and we have not +enabled -XDuplicateRecordFields in M2. This logic is implemented in +dupFieldExport_ok. See test case NoDRFModuleExport. + +Note that this logic only applies to whole-module imports, as we don't want +to allow the following: + + module N0 where + data family D a + module N1 where + import N0 + data instance D Int = MkDInt { foo :: Int } + module N2 where + import N0 + data instance D Bool = MkDBool { foo :: Int } + + module N (D(..)) where + import N1 + import N2 + +Here, the single export item D(..) of N exports both record fields, +`$fld:MkDInt:foo` and `$fld:MkDBool:foo`, so we have to reject the program. +See test overloadedrecfldsfail10. +-} 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 @@ -27,18 +27,22 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import {-# SOURCE #-} GHC.Tc.Gen.Splice + ( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) + import GHC.Hs import GHC.Hs.Syn.Type import GHC.Rename.Utils -import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel -import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types @@ -50,23 +54,24 @@ import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Rename.Expr ( mkExpandedExpr ) -import GHC.Rename.Env ( addUsedGRE ) +import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls, DeprecationWarnings(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType +import GHC.Tc.Zonk.TcType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.PatSyn import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader +import GHC.Core.Class(classTyCon) import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion( mkSymCo ) @@ -74,26 +79,19 @@ import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkBuiltinUnique ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.SrcLoc import GHC.Utils.Misc +import GHC.Data.Bag ( unitBag ) import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import Control.Monad -import GHC.Core.Class(classTyCon) -import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Data.Function -import Data.List (partition, sortBy, intersect) +import Control.Monad import qualified Data.List.NonEmpty as NE -import GHC.Data.Bag ( unitBag ) - {- ************************************************************************ * * @@ -213,7 +211,7 @@ tcExpr e@(HsOverLit _ lit) res_ty = do { mb_res <- tcShortCutLit lit res_ty - -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk + -- See Note [Short cut for overloaded literals] in GHC.Tc.Zonk.Type ; case mb_res of Just lit' -> return (HsOverLit noAnn lit') Nothing -> tcApp e res_ty } @@ -395,7 +393,7 @@ ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty ; return (HsCase x scrut' matches') } where - match_ctxt = MC { mc_what = CaseAlt, + match_ctxt = MC { mc_what = x, mc_body = tcBody } tcExpr (HsIf x pred b1 b2) res_ty @@ -540,10 +538,17 @@ -- in the renamer. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty +tcExpr expr@(RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = possible_parents + , recUpdFields = rbnds } + }) + res_ty = assert (notNull rbnds) $ do { -- Desugar the record update. See Note [Record Updates]. - ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr rbnds res_ty + ; (ds_expr, ds_res_ty, err_ctxt) + <- desugarRecordUpd record_expr possible_parents rbnds res_ty -- Typecheck the desugared expression. ; expr' <- addErrCtxt err_ctxt $ @@ -559,7 +564,8 @@ -- Test case: T10808. } -tcExpr (RecordUpd {}) _ = panic "tcExpr: unexpected overloaded-dot RecordUpd" +tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _ + = pprPanic "tcExpr: unexpected overloaded-dot RecordUpd" $ ppr e {- ************************************************************************ @@ -913,141 +919,8 @@ * * ********************************************************************* -} -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - -Note [Record Updates] -~~~~~~~~~~~~~~~~~~~~~ +{- Note [Record Updates] +~~~~~~~~~~~~~~~~~~~~~~~~ To typecheck a record update, we desugar it first. Suppose we have data T p q = T1 { x :: Int, y :: Bool, z :: Char } | T2 { v :: Char } @@ -1066,75 +939,115 @@ The critical part of desugaring is to identify T and then T1/T4. Wrinkle [Disambiguating fields] -As outlined above, to typecheck a record update via desugaring, we first need -to identify the parent record `TyCon` (`T` above). This can be tricky when several -record types share the same field (with `-XDuplicateRecordFields`). -Currently, we use the inferred type of the record to help disambiguate the record -fields. For example, in + As explained in Note [Disambiguating record updates] in GHC.Rename.Pat, + to typecheck a record update we first need to disambiguate the field labels, + in order to find a parent which has at least one constructor with all of the fields + being updated. - ( mempty :: T a b ) { x = 3 } + As mentioned in Note [Type-directed record disambiguation], we sometimes use + type-directed disambiguation, although this mechanism is deprecated and + scheduled for removal via the implementation of GHC proposal #366 + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. -the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`, -when there might be other datatypes with field `x :: Int`. -This complexity is scheduled for removal via the implementation of GHC proposal #366 -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst -However, for the time being, we still need to disambiguate record fields using the -inferred types. This means that, when typechecking a record update via desugaring, -we need to do the following: +All in all, this means that when typechecking a record update via desugaring, +we take the following steps: - D1. Perform a first typechecking pass on the record expression (`e` in the example above), + (0) Perform a first typechecking pass on the record expression (`e` in the example above), to infer the type of the record being updated. - D2. Desugar the record update as described above, using an HsExpansion. - D3. Typecheck the desugared code. + (1) Disambiguate the record fields (potentially using the type obtained in (0)). + (2) Desugar the record update as described above, using an HsExpansion. + (a) Create a let-binding to share the record update right-hand sides. + (b) Desugar the record update to a case expression updating all the + relevant constructors (those that have all of the fields being updated). + (3) Typecheck the desugared code. -In (D1), we call inferRho to infer the type of the record being updated. This returns the +In (0), we call inferRho to infer the type of the record being updated. This returns the inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc) and a collection of residual constraints. We have no need for the latter two, because we will typecheck again in (D3). So, for the time being (and until GHC proposal #366 is implemented), we simply drop them. Wrinkle [Using IdSig] -As noted above, we want to let-bind the updated fields to avoid code duplication: - let { x' = e1; y' = e2 } in - case e of - T1 _ _ z -> T1 x' y' z - T4 p _ _ -> T4 p y' x' + As noted above, we want to let-bind the updated fields to avoid code duplication: -However, doing so in a naive way would cause difficulties for type inference. -For example: + let { x' = e1; y' = e2 } in + case e of + T1 _ _ z -> T1 x' y' z + T4 p _ _ -> T4 p y' x' - data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } - foo r = r { f = \ k -> (k 3, k 'x') } + However, doing so in a naive way would cause difficulties for type inference. + For example: -If we desugar to: + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } - ds_foo r = - let f' = \ k -> (k 3, k 'x') - in case r of - MkR _ b -> MkR f' b + If we desugar to: -then we are unable to infer an appropriately polymorphic type for f', because we -never infer higher-rank types. To circumvent this problem, we proceed as follows: + ds_foo r = + let f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b - 1. Obtain general field types by instantiating any of the constructors - that contain all the necessary fields. (Note that the field type must be - identical across different constructors of a given data constructor). - 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound - 'Id's a partial type signature. + then we are unable to infer an appropriately polymorphic type for f', because we + never infer higher-rank types. To circumvent this problem, we proceed as follows: -In the above example, it's as if we wrote: + 1. Obtain general field types by instantiating any of the constructors + that contain all the necessary fields. (Note that the field type must be + identical across different constructors of a given data constructor). + 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound + 'Id's a partial type signature. - ds_foo r = - let f' :: (forall a. a -> a) -> (Int, _b) - f' = \ k -> (k 3, k 'x') - in case r of - MkR _ b -> MkR f' b + In the above example, it's as if we wrote: -This allows us to compute the right type for f', and thus accept this record update. + ds_foo r = + let f' :: (forall a. a -> a) -> (Int, _b) + f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b + This allows us to compute the right type for f', and thus accept this record update. + +Note [Type-directed record disambiguation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC currently supports an additional type-directed disambiguation +mechanism, which is deprecated and scheduled for removal as part of +GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. + +To perform this disambiguation, when there are multiple possible parents for +a record update, the renamer defers to the typechecker. +See GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary +function identifyParentLabels, which picks a parent for the record update +using the following additional mechanisms: + + (a) Use the type being pushed in, if it is already a TyConApp. The + following are valid updates at type `R`: + + g :: R -> R + g x = x { fld1 = 3 } + + g' x = x { fld1 = 3 } :: R + + (b) Use the type signature of the record expression, if it exists and + is a TyConApp. Thus this is valid update at type `R`: + + h x = (x :: R) { fld1 = 3 } + +Note that this type-directed disambiguation mechanism isn't very robust, +as it doesn't properly integrate with the rest of the typechecker. +For example, the following updates will all be rejected as ambiguous: + + let r :: R + r = blah + in r { foo = 3 } + + \r. (r { foo = 3 }, r :: R) + +Record updates which require constraint-solving should instead use the +-XOverloadedRecordUpdate extension, as described in Note [Overview of record dot syntax]. + Note [Unifying result types in tcRecordUpd] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ After desugaring and typechecking a record update in the way described in @@ -1190,7 +1103,10 @@ -- result type of this desugared record update. desugarRecordUpd :: LHsExpr GhcRn -- ^ @record_expr@: expression to which the record update is applied - -> [LHsRecUpdField GhcRn] + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -- ^ Possible parent 'TyCon'/'PatSyn's for the record update, + -- with the associated constructors and field labels + -> [LHsRecUpdField GhcRn GhcRn] -- ^ the record update fields -> ExpRhoType -- ^ the expected result type of the record update @@ -1202,8 +1118,9 @@ -- error context to push when typechecking -- the desugared code ) -desugarRecordUpd record_expr rbnds res_ty - = do { -- STEP -2: typecheck the record_expr, the record to be updated +desugarRecordUpd record_expr possible_parents rbnds res_ty + = do { -- STEP 0: typecheck the record_expr, the record to be updated. + -- -- Until GHC proposal #366 is implemented, we still use the type of -- the record to disambiguate its fields, so we must infer the record -- type here before we can desugar. See Wrinkle [Disambiguating fields] @@ -1234,73 +1151,36 @@ -- -- This should definitely *not* typecheck. - -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty + -- STEP 1: disambiguate the record update by computing a single parent + -- which has a constructor with all of the fields being updated. + -- + -- See Note [Disambiguating record updates] in GHC.Rename.Pat. + ; (cons, rbinds) + <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds - upd_fld_occs = map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds sel_ids = map selectorAmbiguousFieldOcc upd_flds upd_fld_names = map idName sel_ids - - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See Note [Mixed Record Field Updates] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; massert (all isPatSynRecordSelector pat_syn_sels) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- STEP 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; case relevant_cons of - { [] -> failWithTc (badFieldsUpd rbinds con_likes) - ; relevant_con : _ -> + relevant_cons = nonDetEltsUniqSet cons + relevant_con = head relevant_cons - -- STEP 3 - -- Create new variables for the fields we are updating, - -- so that we can share them across constructors. + -- STEP 2: desugar the record update. -- - -- Example: + -- (a) Create new variables for the fields we are updating, + -- so that we can share them across constructors. -- - -- e { x=e1, y=e2 } + -- Example: -- - -- We want to let-bind variables to `e1` and `e2`: + -- e { x=e1, y=e2 } -- - -- let x' :: Int - -- x' = e1 - -- y' :: Bool - -- y' = e2 - -- in ... + -- We want to let-bind variables to `e1` and `e2`: + -- + -- let x' :: Int + -- x' = e1 + -- y' :: Bool + -- y' = e2 + -- in ... - do { -- Instantiate the type variables of any relevant constuctor + -- Instantiate the type variables of any relevant constuctor -- with metavariables to obtain a type for each 'Id'. -- This will allow us to have 'Id's with polymorphic types -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates]. @@ -1320,7 +1200,7 @@ -- e.g. (x', e1), (y', e2), ... ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn)) mk_upd_id fld_nm (L _ rbind) - = do { let Scaled m arg_ty = lookupNameEnv_NF arg_ty_env fld_nm + = do { let Scaled _ arg_ty = lookupNameEnv_NF arg_ty_env fld_nm nm_occ = rdrNameOcc . nameRdrName $ fld_nm actual_arg_ty = substTy subst arg_ty rhs = hfbRHS rbind @@ -1331,11 +1211,17 @@ -- (As we will typecheck the let-bindings later, we can drop this coercion here.) -- See RepPolyRecordUpdate test. ; nm <- newNameAt nm_occ generatedSrcSpan - ; let id = mkLocalId nm m actual_arg_ty + ; let id = mkLocalId nm ManyTy actual_arg_ty -- NB: create fresh names to avoid any accidental shadowing -- occurring in the RHS expressions when creating the let bindings: -- -- let x1 = e1; x2 = e2; ... + -- + -- Above, we use multiplicity Many rather than the one associated to arg_ty. + -- Normally, there shouldn't be a difference, since it's a let binding. + -- But -XStrict can convert the let to a case, and this causes issues + -- in test LinearRecUpd. Since we don't support linear record updates, + -- using Many is simple and safe. ; return (fld_nm, (id, rhs)) } arg_ty_env = mkNameEnv @@ -1343,6 +1229,10 @@ (conLikeFieldLabels relevant_con) arg_tys + ; traceTc "tcRecordUpd" $ + vcat [ text "upd_fld_names:" <+> ppr upd_fld_names + , text "relevant_cons:" <+> ppr relevant_cons ] + ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn) updEnv = listToUniqMap $ upd_ids @@ -1385,17 +1275,17 @@ Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id)) -- Field is not being updated: LHS = variable pattern, RHS = that same variable. _ -> let fld_nm = mkInternalName (mkBuiltinUnique i) - (mkVarOccFS (field_label $ flLabel fld_lbl)) + (nameOccName $ flSelector $ fld_lbl) generatedSrcSpan in (genVarPat fld_nm, genLHsVar fld_nm) - -- STEP 4 - -- Desugar to HsCase, as per note [Record Updates] + -- STEP 2 (b): desugar to HsCase, as per note [Record Updates] ; let ds_expr :: HsExpr GhcRn ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) case_expr :: HsExpr GhcRn - case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches)) + case_expr = HsCase RecUpd record_expr + $ mkMatchGroup (Generated DoPmc) (wrapGenSpan matches) matches :: [LMatch GhcRn (LHsExpr GhcRn)] matches = map make_pat relevant_cons @@ -1432,7 +1322,7 @@ else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ] err_ctxt = make_lines_msg err_lines - ; return (ds_expr, ds_res_ty, err_ctxt) } } } + ; return (ds_expr, ds_res_ty, err_ctxt) } -- | Pretty-print a collection of lines, adding commas at the end of each line, -- and adding "and" to the start of the last line. @@ -1446,118 +1336,142 @@ * * Record bindings * * -********************************************************************* -} +**********************************************************************-} --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head +-- | Disambiguate the fields in a record update. +-- +-- Most of the disambiguation has been done by the renamer; this function +-- performs a final type-directed disambiguation pass, as explained in +-- Note [Type-directed record disambiguation]. disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType - -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -disambiguateRecordBinds record_expr record_rho rbnds res_ty - -- Are all the fields unambiguous? - = case mapM isUnambiguous rbnds of - -- If so, just skip to looking up the Ids - -- Always the case if DuplicateRecordFields is off - Just rbnds' -> mapM lookupSelector rbnds' - Nothing -> -- If not, try to identify a single parent - do { fam_inst_envs <- tcGetFamInstEnvs - -- Look up the possible parents for each field - ; rbnds_with_parents <- getUpdFieldsParents - ; let possible_parents = map (map fst . snd) rbnds_with_parents - -- Identify a single parent - ; p <- identifyParent fam_inst_envs possible_parents - -- Pick the right selector with that parent for each field - ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> [LHsRecUpdField GhcRn GhcRn] -> ExpRhoType + -> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn]) +disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty + = do { fam_inst_envs <- tcGetFamInstEnvs + -- Identify a single parent, using type-directed disambiguation + -- if necessary. (Note that type-directed disambiguation of + -- record field updates is is scheduled for removal, as per + -- Note [Type-directed record disambiguation].) + ; TcRecUpdParent + { tcRecUpdLabels = lbls + , tcRecUpdCons = cons } + <- identifyParentLabels fam_inst_envs possible_parents + -- Pick the right selector with that parent for each field + ; rbnds' <- zipWithM lookupField (NE.toList lbls) rbnds + ; return (cons, rbnds') } where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) - Ambiguous{} -> Nothing - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc) - rbnds - - -- Given a the lists of possible parents for each field, - -- identify a single parent - identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent - identifyParent fam_inst_envs possible_parents - = case foldr1 intersect possible_parents of - -- No parents for all fields: record update is ill-typed - [] -> failWithTc (TcRnNoPossibleParentForFields rbnds) + -- Try to identify a single parent, using type-directed disambiguation. + -- + -- Any non-type-directed disambiguation will have been done already. + -- See GHC.Rename.Env.lookupRecUpdFields. + identifyParentLabels :: FamInstEnvs + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + identifyParentLabels fam_inst_envs possible_parents + = case possible_parents of - -- Exactly one datatype with all the fields: use that - [p] -> return p + -- Exactly one possible parent for the record update! + p NE.:| [] -> lookup_parent_flds p - -- Multiple possible parents: try harder to disambiguate + -- Multiple possible parents: try harder to disambiguate. -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> - do { reportAmbiguousField p - ; return (RecSelData p) } + -- + -- See (a) in Note [Type-directed record disambiguation] in GHC.Rename.Pat. + _ NE.:| _ : _ + | Just tc <- tyConOfET fam_inst_envs res_ty + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } -- Does the expression being updated have a type signature? - -- If so, try to extract a parent TyCon from it - | Just {} <- obviousSig (unLoc record_expr) - , Just tc <- tyConOf fam_inst_envs record_rho - -> do { reportAmbiguousField tc - ; return (RecSelData tc) } + -- If so, try to extract a parent TyCon from it. + -- + -- See (b) inNote [Type-directed record disambiguation] in GHC.Rename.Pat. + | Just {} <- obviousSig (unLoc record_expr) + , Just tc <- tyConOf fam_inst_envs record_rho + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } -- Nothing else we can try... - _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds) + p1 NE.:| p2 : ps + -> do { p1 <- tcLookupRecSelParent p1 + ; p2 <- tcLookupRecSelParent p2 + ; ps <- mapM tcLookupRecSelParent ps + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ MultiplePossibleParents (p1, p2, ps) } - -- Make a field unambiguous by choosing the given parent. - -- Emits an error if the field cannot have that parent, - -- e.g. if the user writes - -- r { x = e } :: T - -- where T does not have field x. - pickParent :: RecSelParent - -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - pickParent p (upd, xs) - = case lookup p xs of - -- Phew! The parent is valid for this field. - -- Previously ambiguous fields must be marked as - -- used now that we know which one is meant, but - -- unambiguous ones shouldn't be recorded again - -- (giving duplicate deprecation warnings). - Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hfbLHS (unLoc upd) - setSrcSpanA loc $ addUsedGRE True gre - ; lookupSelector (upd, greMangledName gre) } - -- The field doesn't belong to this parent, so report - -- an error but keep going through all the fields - Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, greMangledName (snd (head xs))) } + -- Try to use the 'TyCon' we learned from type-directed disambiguation. + -- This might not work, if it doesn't match up with any of the parents we had + -- computed on the basis of the field labels. + -- (See test cases overloadedrecfields01 and T21946.) + try_disambiguated_tycon :: TyCon + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + try_disambiguated_tycon tc pars + = do { pars <- mapMaybeM (fmap (guard_parent tc) . lookup_parent_flds) (NE.toList pars) + ; case pars of + [par] -> return par + [] -> do { pars <- mapM tcLookupRecSelParent possible_parents + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ InvalidTyConParent tc pars } + _ -> pprPanic "try_disambiguated_tycon: more than 1 valid parent" + (ppr $ map tcRecUpdParent pars) } - -- Given a (field update, selector name) pair, look up the - -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n - ; let L loc af = hfbLHS upd - lbl = rdrNameAmbiguousFieldOcc af + guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc) + guard_parent disamb_tc cand_parent@(TcRecUpdParent { tcRecUpdParent = cand_tc }) + = do { guard (RecSelData disamb_tc == cand_tc) + ; return cand_parent } + + lookup_parent_flds :: HsRecUpdParent GhcRn + -> TcM (HsRecUpdParent GhcTc) + lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons }) + = do { let cons' :: NonDetUniqFM ConLike ConLikeName + cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons + ; cons <- traverse (tcLookupConLike . conLikeName_Name) cons' + ; tc <- tcLookupRecSelParent par + ; return $ + TcRecUpdParent + { tcRecUpdParent = tc + , tcRecUpdLabels = lbls + , tcRecUpdCons = unsafeUFMToUniqSet $ getNonDet cons } } + + lookupField :: FieldGlobalRdrElt + -> LHsRecUpdField GhcRn GhcRn + -> TcM (LHsRecUpdField GhcTc GhcRn) + lookupField fld_gre (L l upd) + = do { let L loc af = hfbLHS upd + lbl = ambiguousFieldOccRdrName af + mb_gre = pickGREs lbl [fld_gre] + -- NB: this GRE can be 'Nothing' when in GHCi. + -- See test T10439. + + -- Mark the record fields as used, now that we have disambiguated. + -- There is no risk of duplicate deprecation warnings, as we have + -- not marked the GREs as used previously. + ; setSrcSpanA loc $ mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre + ; sel <- tcLookupId (greName fld_gre) ; return $ L l HsFieldBind { hfbAnn = hfbAnn upd - , hfbLHS - = L (l2l loc) (Unambiguous i (L (l2l loc) lbl)) + , hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl) , hfbRHS = hfbRHS upd , hfbPun = hfbPun upd - } - } + } } - -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head - reportAmbiguousField :: TyCon -> TcM () - reportAmbiguousField parent_type = - setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type + -- The type-directed disambiguation mechanism is scheduled for removal, + -- as per Note [Type-directed record disambiguation]. + -- So we emit a warning whenever the user relies on it. + reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn) + -> TyCon -> TcM () + reportAmbiguousUpdate parents parent_type = + setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousRecordUpdate rupd parent_type where - rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } + rupd = RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = rbnds } + , rupd_ext = noExtField } loc = getLocA (head rbnds) {- @@ -1599,14 +1513,15 @@ = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing - -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f' - -- , hfbRHS = rhs' }))) } Just (f', rhs') -> return (Just (L l (HsFieldBind { hfbAnn = hfbAnn fld , hfbLHS = f' , hfbRHS = rhs' , hfbPun = hfbPun fld}))) } +fieldCtxt :: FieldLabelString -> SDoc +fieldCtxt field_name + = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn @@ -1646,14 +1561,14 @@ | otherwise = do -- A record unless (null missing_s_fields) $ do - fs <- zonk_fields missing_s_fields + fs <- liftZonkM $ zonk_fields missing_s_fields -- It is an error to omit a strict field, because -- we can't substitute it with (error "Missing field f") addErrTc (TcRnMissingStrictFields con_like fs) warn <- woptM Opt_WarnMissingFields when (warn && notNull missing_ns_fields) $ do - fs <- zonk_fields missing_ns_fields + fs <- liftZonkM $ zonk_fields missing_ns_fields -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. @@ -1684,103 +1599,6 @@ field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" - -badFieldsUpd - :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -- Field names that don't belong to a single datacon - -> [ConLike] -- Data cons of the type which the first field name belongs to - -> TcRnMessage -badFieldsUpd rbinds data_cons - = TcRnNoConstructorHasAllFields conflictingFields - -- See Note [Finding the conflicting fields] - where - -- A (preferably small) set of fields such that no constructor contains - -- all of them. See Note [Finding the conflicting fields] - conflictingFields = case nonMembers of - -- nonMember belongs to a different type. - (nonMember, _) : _ -> [aMember, nonMember] - [] -> let - -- All of rbinds belong to one type. In this case, repeatedly add - -- a field to the set until no constructor contains the set. - - -- Each field, together with a list indicating which constructors - -- have all the fields so far. - growingSets :: [(FieldLabelString, [Bool])] - growingSets = scanl1 combine membership - combine (_, setMem) (field, fldMem) - = (field, zipWith (&&) setMem fldMem) - in - -- Fields that don't change the membership status of the set - -- are redundant and can be dropped. - map (fst . NE.head) $ NE.groupWith snd growingSets - - aMember = assert (not (null members) ) fst (head members) - (members, nonMembers) = partition (or . snd) membership - - -- For each field, which constructors contain the field? - membership :: [(FieldLabelString, [Bool])] - membership = sortMembership $ - map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $ - map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds - - fieldLabelSets :: [UniqSet FieldLabelString] - fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons - - -- Sort in order of increasing number of True, so that a smaller - -- conflicting set can be found. - sortMembership = - map snd . - sortBy (compare `on` fst) . - map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) - - countTrue = count id - -{- -Note [Finding the conflicting fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data A = A {a0, a1 :: Int} - | B {b0, b1 :: Int} -and we see a record update - x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } -Then we'd like to find the smallest subset of fields that no -constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. -We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's -hard to see what was really wrong. - -We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } - | C { z,x :: Int, v::Int } -with update - r { x=e1, y=e2, z=e3 }, we - -Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See #7989. --} - -mixedSelectors :: [Id] -> [Id] -> TcRnMessage -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" {- ************************************************************************ 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 @@ -82,6 +82,9 @@ ( WriterT, runWriterT, tell ) import Control.Monad.Trans.Class ( lift ) +import Data.Maybe (isJust) +import GHC.Types.RepType (tyConPrimRep) +import GHC.Builtin.Types (unitTyCon) -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool @@ -267,7 +270,7 @@ id = mkLocalId nm ManyTy sig_ty -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, - -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it). + -- (so GHC.Tc.Zonk.Type.zonkForeignExports ignores it). ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and @@ -567,3 +570,225 @@ foreignDeclCtxt fo = hang (text "When checking declaration:") 2 (ppr fo) + + +{- Predicates on Types used in this module -} + +-- | Reason why a type in an FFI signature is invalid + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + +isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty + +isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty + +isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normaliseFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = IsValid + | otherwise + = NotValid (ForeignDynNotPtr expected ty) + +isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. +isFFILabelTy ty = checkRepTyCon ok ty + where + ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + = IsValid + | otherwise + = NotValid ForeignLabelNotAPtr + +-- | Check validity for a type of the form @Any :: k@. +-- +-- This function returns: +-- +-- - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@, +-- - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types, +-- - @Nothing@ if the type is not @Any@. +checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason) +checkAnyTy ty + | Just ki <- anyTy_maybe ty + = Just $ + if isJust $ kindBoxedRepLevity_maybe ki + then IsValid + -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305. + else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny) + | otherwise + = Nothing + +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType), +-- which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. +isFFIPrimArgumentTy dflags ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid result type for a 'foreign import prim' Currently +-- it must be an unlifted type, including unboxed tuples, unboxed +-- sums, or the well-known type Any (at kind Type or UnliftedType). +isFFIPrimResultTy dflags ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + +isFunPtrTy :: Type -> Bool +isFunPtrTy ty + | Just (tc, [_]) <- splitTyConApp_maybe ty + = tc `hasKey` funPtrTyConKey + | otherwise + = False + +-- normaliseFfiType gets run before checkRepTyCon, so we don't +-- need to worry about looking through newtypes or type functions +-- here; that's already been taken care of. +checkRepTyCon + :: (TyCon -> Validity' TypeCannotBeMarshaledReason) + -> Type + -> Validity' IllegalForeignTypeReason +checkRepTyCon check_tc ty + = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (mk_nt_reason tc tys) + | otherwise -> check_tc tc + Nothing -> NotValid NotADataType + where + mk_nt_reason tc tys = NewtypeDataConNotInScope tc tys + +{- +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- +-} + +legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +legalFEArgTyCon tc + -- It's illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +legalFIResultTyCon dflags tc + | tc == unitTyCon = IsValid + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +legalFEResultTyCon tc + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags _ tc + = marshalableTyCon dflags tc + +-- Check for marshalability of a primitive type. +-- We exclude lifted types such as RealWorld and TYPE. +-- They can technically appear in types, e.g. +-- f :: RealWorld -> TYPE LiftedRep -> RealWorld +-- f x _ = x +-- but there are no values of type RealWorld or TYPE LiftedRep, +-- so it doesn't make sense to use them in FFI. +marshalablePrimTyCon :: TyCon -> Bool +marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) + +marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +marshalableTyCon dflags tc + | marshalablePrimTyCon tc + , not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + | otherwise + = boxedMarshalableTyCon tc + +boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +boxedMarshalableTyCon tc + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + ] + = IsValid + + | otherwise = NotValid NotABoxedMarshalableTyCon + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Check args of 'foreign import prim', only allow simple unlifted types. +legalFIPrimArgTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + | otherwise + = NotValid NotSimpleUnliftedType + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple and sum result types. +legalFIPrimResultTyCon dflags tc + | marshalablePrimTyCon tc + , not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + + | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc + = validIfUnliftedFFITypes dflags + + | otherwise + = NotValid $ NotSimpleUnliftedType + +validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason +validIfUnliftedFFITypes dflags + | xopt LangExt.UnliftedFFITypes dflags = IsValid + | otherwise = NotValid UnliftedFFITypesNeeded + +{- +Note [Marshalling void] +~~~~~~~~~~~~~~~~~~~~~~~ +We don't treat State# (whose PrimRep is VoidRep) as marshalable. +In turn that means you can't write + foreign import foo :: Int -> State# RealWorld + +Reason: the back end falls over with panic "primRepHint:VoidRep"; + and there is no compelling reason to permit it +-} diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -26,8 +26,8 @@ , tcInferAppHead, tcInferAppHead_maybe , tcInferId, tcCheckId , obviousSig - , tyConOf, tyConOfET, lookupParents, fieldNotInType - , notSelector, nonBidirectionalErr + , tyConOf, tyConOfET, fieldNotInType + , nonBidirectionalErr , addHeadCtxt, addExprCtxt, addFunResCtxt ) where @@ -35,6 +35,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Hs.Syn.Type import GHC.Tc.Gen.HsType import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) @@ -47,7 +48,8 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) -import GHC.Unit.Module ( getModule ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Core.UsageEnv ( singleUsageUE ) import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env @@ -55,10 +57,9 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Types.Evidence -import GHC.Hs.Syn.Type +import GHC.Tc.Zonk.TcType -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Core.UsageEnv ( unitUE ) + import GHC.Core.PatSyn( PatSyn ) import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon @@ -80,7 +81,7 @@ import GHC.Builtin.Names.TH( liftStringName, liftName ) import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic @@ -860,36 +861,12 @@ tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents is_selector rdr - = do { env <- getGlobalRdrEnv - -- Filter by isRecFldGRE because otherwise a non-selector variable with - -- an overlapping name can get through when NoFieldSelectors is enabled. - -- See Note [NoFieldSelectors] in GHC.Rename.Env. - ; let all_gres = lookupGRE_RdrName' rdr env - ; let gres | is_selector = filter isFieldSelectorGRE all_gres - | otherwise = filter isRecFldGRE all_gres - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (greMangledName gre) - ; case recordSelectorTyCon_maybe id of - Just rstc -> return (rstc, gre) - Nothing -> failWithTc (notSelector (greMangledName gre)) } - - fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr = mkTcRnNotInScope rdr $ UnknownSubordinate (text "field of type" <+> quotes (ppr p)) -notSelector :: Name -> TcRnMessage -notSelector = TcRnNotARecordSelector - {- ********************************************************************* * * Expressions with a type signature @@ -936,7 +913,7 @@ <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted ; emitConstraints residual - ; tau <- zonkTcType tau + ; tau <- liftZonkM $ zonkTcType tau ; let inferred_theta = map evVarPred givens tau_tvs = tyCoVarsOfType tau ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta @@ -1108,21 +1085,15 @@ get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) - dflags <- getDynFlags - rdr_env <- getGlobalRdrEnv lcl_env <- getLocalRdrEnv - imp_info <- getImports - curr_mod <- getModule - hpt <- getHpt - return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - lcl_env imp_info (mkRdrUnqual occ) + unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ) return_id id = return (HsVar noExtField (noLocA id), idType id) check_local_id :: Id -> TcM () check_local_id id = do { checkThLocalId id - ; tcEmitBindingUsage $ unitUE (idName id) OneTy } + ; tcEmitBindingUsage $ singleUsageUE id } check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id @@ -1214,7 +1185,7 @@ The 'p' is the multiplicity unification variable, which will by now have been unified to something, or defaulted in - `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an + `GHC.Tc.Zonk.Type.commitFlexi`. So it won't just be an (unbound) variable. So a saturated application (K e), where e::Int will desugar to @@ -1318,7 +1289,8 @@ -- bindings of the same splice proxy, but that doesn't -- matter, although it's a mite untidy. do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (TcRnSplicePolymorphicLocalVar id) + ; checkTc (isTauTy id_ty) $ + TcRnTHError $ TypedTHError $ SplicePolymorphicLocalVar id -- If x is polymorphic, its occurrence sites might -- have different instantiations, so we can't use plain -- 'x' as the splice proxy name. I don't know how to @@ -1387,21 +1359,20 @@ -- But not in generated code, where we don't want -- to mention internal (rebindable syntax) function names addFunResCtxt fun args fun_res_ty env_ty thing_inside - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) thing_inside + = do { env_tv <- newFlexiTyVarTy liftedTypeKind + ; dumping <- doptM Opt_D_dump_tc_trace + ; addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg dumping env_tv) thing_inside } -- NB: use a landmark error context, so that an empty context -- doesn't suppress some more useful context where - mk_msg + mk_msg dumping env_tv = do { mb_env_ty <- readExpType_maybe env_ty -- by the time the message is rendered, the ExpType -- will be filled in (except if we're debugging) ; fun_res' <- zonkTcType fun_res_ty ; env' <- case mb_env_ty of Just env_ty -> zonkTcType env_ty - Nothing -> - do { dumping <- doptM Opt_D_dump_tc_trace - ; massert dumping - ; newFlexiTyVarTy liftedTypeKind } + Nothing -> do { massert dumping; return env_tv } ; let -- See Note [Splitting nested sigma types in mismatched -- function types] (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' 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 @@ -83,6 +83,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType @@ -90,11 +91,12 @@ import GHC.Tc.Utils.Unify import GHC.IfaceToCore import GHC.Tc.Solver -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs, tcInstTypeBndrs ) +import GHC.Tc.Zonk.TcType import GHC.Core.Type import GHC.Core.Predicate @@ -124,7 +126,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Builtin.Names hiding ( wildCardName ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import qualified GHC.LanguageExtensions as LangExt import GHC.Data.FastString @@ -137,7 +139,7 @@ import Data.Function ( on ) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE -import Data.List ( find, mapAccumL ) +import Data.List ( mapAccumL ) import Control.Monad import Data.Tuple( swap ) @@ -388,11 +390,11 @@ -- meth :: forall a (x :: f a). Proxy x -> () -- When instantiating Proxy with kappa, we must unify kappa := f a. But we're -- still working out the kind of f, and thus f a will have a coercion in it. --- Coercions block unification (Note [Equalities with incompatible kinds] in --- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll --- end up promoting kappa to the top level (because kind-generalization is --- normally done right before adding a binding to the context), and then we --- can't set kappa := f a, because a is local. +-- Coercions may block unification (Note [Equalities with incompatible kinds] in +-- GHC.Tc.Solver.Equality, wrinkle (EIK2)) and so we fail to unify. If we try to +-- kind-generalize, we'll end up promoting kappa to the top level (because +-- kind-generalization is normally done right before adding a binding to the context), +-- and then we can't set kappa := f a, because a is local. kcClassSigType names sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty })) = addSigCtxt (funsSigCtxt names) sig_ty $ @@ -443,7 +445,7 @@ ; traceTc "tcHsSigType 2" (ppr implic) ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic)) - ; ty <- zonkTcType ty + ; ty <- liftZonkM $ zonkTcType ty ; checkValidType ctxt ty ; traceTc "end tcHsSigType }" (ppr ty) ; return ty } @@ -473,7 +475,7 @@ -- Default any unconstrained variables free in the kind -- See Note [Escaping kind in type signatures] ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind - ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind) + ; doNotQuantifyTyVars exp_kind_dvs (err_ctx exp_kind) ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) ; outer_bndrs <- scopedSortOuter outer_bndrs @@ -488,10 +490,9 @@ ; return (implic, mkInfForAllTys kvs ty1) } where - mk_doc exp_kind tidy_env + err_ctx exp_kind tidy_env = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind - ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind) - 2 (text "of type signature:" <+> ppr full_hs_ty)) } + ; return (tidy_env2, UninfTyCtx_Sig exp_kind full_hs_ty) } @@ -619,8 +620,8 @@ ; kvs <- kindGeneralizeAll skol_info ty1 -- "All" because it's a top-level type ; reportUnsolvedEqualities skol_info kvs tclvl wanted - ; ze <- mkEmptyZonkEnv NoFlexi - ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1) + ; final_ty <- initZonkEnv DefaultFlexi + $ zonkTcTypeToTypeX (mkInfForAllTys kvs ty1) ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) ; return final_ty } where @@ -703,7 +704,7 @@ -- We still must call kindGeneralizeNone, though, according -- to Note [Recipe for checking a signature] ; kindGeneralizeNone ty - ; ty <- zonkTcType ty + ; ty <- liftZonkM $ zonkTcType ty ; checkValidType TypeAppCtxt ty ; return ty } @@ -757,7 +758,7 @@ ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats -- Hack alert: see Note [tcFamTyPats: zonking the result kind] - ; res_kind <- zonkTcType res_kind + ; res_kind <- liftZonkM $ zonkTcType res_kind ; traceTc "End tcFamTyPats }" $ vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] @@ -1041,7 +1042,8 @@ -- things like instantiate its foralls, so it needs -- to be fully determined (#14904) ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig') - ; ty' <- tc_lhs_type mode ty sig' + ; ty' <- tcAddKindSigPlaceholders sig $ + tc_lhs_type mode ty sig' ; return (ty', sig') } -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate @@ -1063,7 +1065,7 @@ -- Raw uniques since we go from NameEnv to TvSubstEnv. let subst_prs :: [(Unique, TcTyVar)] subst_prs = [ (getUnique nm, tv) - | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ] + | ATyVar nm tv <- nonDetNameEnvElts (getLclEnvTypeEnv env) ] subst = mkTvSubst (mkInScopeSetList $ map snd subst_prs) (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs) @@ -1145,7 +1147,7 @@ tc_hs_type _ ty@(HsRecTy {}) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now - = failWithTc $ TcRnIllegalRecordSyntax ty + = failWithTc $ TcRnIllegalRecordSyntax (Right ty) -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment @@ -1215,7 +1217,7 @@ | otherwise = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys - ; kinds <- mapM zonkTcType kinds + ; kinds <- liftZonkM $ mapM zonkTcType kinds -- Infer each arg type separately, because errors can be -- confusing if we give them a shared kind. Eg #7410 -- (Either Int, Int), we do not want to get an error saying @@ -1251,6 +1253,12 @@ --------- Promoted lists and tuples tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind + -- The '[] case is handled in tc_infer_hs_type. + -- See Note [Future-proofing the type checker]. + | null tys + = tc_infer_hs_type_ek mode rn_ty exp_kind + + | otherwise = do { tks <- mapM (tc_infer_lhs_type mode) tys ; (taus', kind) <- unifyKinds tys tks ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') @@ -1519,11 +1527,11 @@ is_app _ = False go :: LHsType GhcRn - -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)] + -> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)] -> (LHsType GhcRn, - [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp + [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) + go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as) go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) go (L _ (HsOpTy _ prom l op@(L sp _) r)) as = ( L (na2la sp) (HsTyVar noAnn prom op) @@ -1615,8 +1623,7 @@ case ki_binder of -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon _ af | isInvisibleFunArg af -> instantiate ki_binder inner_ki + Named (Bndr kv Inferred) -> instantiate kv inner_ki Named (Bndr _ Specified) -> -- Visible kind application do { traceTc "tcInferTyApps (vis kind app)" @@ -1646,9 +1653,9 @@ ---------------- HsValArg: a normal argument (fun ty) (HsValArg arg : args, Just (ki_binder, inner_ki)) -- next binder is invisible; need to instantiate it - | isInvisiblePiTyBinder ki_binder -- FunTy with constraint on LHS; - -- or ForAllTy with Inferred or Specified - -> instantiate ki_binder inner_ki + | Named (Bndr kv flag) <- ki_binder + , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified + -> instantiate kv inner_ki -- "normal" case | otherwise @@ -1670,7 +1677,7 @@ do { let arrows_needed = n_initial_val_args all_args ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki - ; fun' <- zonkTcType (fun `mkCastTy` co) + ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTy` co) -- This zonk is essential, to expose the fruits -- of matchExpectedFunKind to the 'go' loop @@ -1701,7 +1708,7 @@ substed_fun_ki = substTy subst fun_ki hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) - n_initial_val_args :: [HsArg tm ty] -> Arity + n_initial_val_args :: [HsArg p tm ty] -> Arity -- Count how many leading HsValArgs we have n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args @@ -1735,8 +1742,7 @@ , isTypeSynonymTyCon tc , args `lengthIs` (tyConArity tc - 1) , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym - = do { arg' <- zonkTcType arg - ; args' <- zonkTcTypes args + = do { (arg':args') <- liftZonkM $ zonkTcTypes (arg:args) ; let subst' = case ki_binder of Anon {} -> subst Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' @@ -1749,7 +1755,7 @@ mkAppTyM subst fun (Named (Bndr tv _)) arg = do { arg' <- if isTrickyTvBinder tv then -- See Note [mkAppTyM]: Nasty case 1 - zonkTcType arg + liftZonkM $ zonkTcType arg else return arg ; return ( extendTvSubstAndInScope subst tv arg' , mk_app_ty fun arg' ) } @@ -1820,7 +1826,7 @@ Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy, we must be aware of this when splitting: splitTyConApp and splitAppTy will *not* split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy] -in GHC.Tc.Solver.Canonical. +in GHC.Tc.Solver.Equality. Note [mkAppTyM] ~~~~~~~~~~~~~~~ @@ -1893,10 +1899,10 @@ appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args -appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg l arg : args) - = appTypeToArg (mkHsAppKindTy l f arg) args +appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args +appTypeToArg f (HsTypeArg at arg : args) + = appTypeToArg (mkHsAppKindTy f at arg) args {- ********************************************************************* @@ -1934,7 +1940,7 @@ ; if act_kind' `tcEqType` exp_kind then return res_ty -- This is very common - else do { co_k <- uType KindLevel origin act_kind' exp_kind + else do { co_k <- unifyTypeAndEmit KindLevel origin act_kind' exp_kind ; traceTc "checkExpectedKind" (vcat [ ppr act_kind , ppr exp_kind , ppr co_k ]) @@ -1986,23 +1992,16 @@ -- see #15245 promotionErr name FamDataConPE ; let (_, _, _, theta, _, _) = dataConFullSig dc - ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta)) - ; case dc_theta_illegal_constraint theta of - Just pred -> promotionErr name $ - ConstrainedDataConPE pred - Nothing -> pure () + ; traceTc "tcTyVar" (ppr dc <+> ppr theta) + -- promotionErr: Note [No constraints in kinds] in GHC.Tc.Validity + ; unless (null theta) $ + promotionErr name (ConstrainedDataConPE theta) ; let tc = promoteDataCon dc ; return (mkTyConApp tc [], tyConKind tc) } APromotionErr err -> promotionErr name err - _ -> wrongThingErr "type" thing name } - where - -- We cannot promote a data constructor with a context that contains - -- constraints other than equalities, so error if we find one. - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - dc_theta_illegal_constraint :: ThetaType -> Maybe PredType - dc_theta_illegal_constraint = find (not . isEqPred) + _ -> wrongThingErr WrongThingType thing name } {- Note [Recursion through the kinds] @@ -2045,7 +2044,7 @@ Moreover in instance heads we get forall-types with kind Constraint. -It's tempting to check that the body kind is either * or #. But this is +It's tempting to check that the body kind is (TYPE _). But this is wrong. For example: class C a b @@ -2054,7 +2053,7 @@ We're doing newtype-deriving for C. But notice how `a` isn't in scope in the predicate `C a`. So we quantify, yielding `forall a. C a` even though `C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for * or # here. +convenient. Bottom line: don't check for (TYPE _) here. Note [Body kind of a HsQualTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2112,7 +2111,7 @@ * It zonks any kinds. The returned type should have no mutable kind or type variables (hence returning Type not TcType): - any unconstrained kind variables are defaulted to (Any *) just - as in GHC.Tc.Utils.Zonk. + as in GHC.Tc.Zonk.Type. - there are no mutable type variables because we are kind-checking a type Reason: the returned type may be put in a TyCon or DataCon where @@ -2312,10 +2311,10 @@ | InitialKindInfer -- Does the declaration have a standalone kind signature (SAKS) or a complete --- user-specified kind (CUSK)? +-- user-supplied kind (CUSK)? data SAKS_or_CUSK = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-specified kind (CUSK) + | CUSK -- Complete user-supplied kind (CUSK) instance Outputable SAKS_or_CUSK where ppr (SAKS k) = text "SAKS" <+> ppr k @@ -2324,11 +2323,11 @@ -- See Note [kcCheckDeclHeader vs kcInferDeclHeader] kcDeclHeader :: InitialKindStrategy - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig kcDeclHeader InitialKindInfer = kcInferDeclHeader @@ -2351,20 +2350,20 @@ ------------------------------ kcCheckDeclHeader :: SAKS_or_CUSK - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk kcCheckDeclHeader_cusk - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon + :: Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon kcCheckDeclHeader_cusk name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki @@ -2372,7 +2371,7 @@ -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl = addTyConFlavCtxt name flav $ do { skol_info <- mkSkolemInfo skol_info_anon - ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind))) + ; (tclvl, wanted, (scoped_kvs, (tc_bndrs, res_kind))) <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $ bindImplicitTKBndrs_Q_Skol skol_info kv_ns $ bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs $ @@ -2380,7 +2379,7 @@ -- Now, because we're in a CUSK, -- we quantify over the mentioned kind vars - ; let spec_req_tkvs = scoped_kvs ++ tc_tvs + ; let spec_req_tkvs = scoped_kvs ++ binderVars tc_bndrs all_kinds = res_kind : map tyVarKind spec_req_tkvs ; candidates <- candidateQTyVarsOfKinds all_kinds @@ -2392,9 +2391,11 @@ candidates `delCandidates` spec_req_tkvs -- NB: 'inferred' comes back sorted in dependency order - ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_tvs are skolems, - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs -- so zonkTyCoVarKind suffices - ; res_kind <- zonkTcType res_kind + ; (scoped_kvs, tc_bndrs, res_kind) <- liftZonkM $ + do { scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_bndrs are skolems, + ; tc_bndrs <- mapM zonkTyCoVarBndrKind tc_bndrs -- so zonkTyCoVarBndrKind suffices + ; res_kind <- zonkTcType res_kind + ; return (scoped_kvs, tc_bndrs, res_kind) } ; let mentioned_kv_set = candidateKindVars candidates specified = scopedSort scoped_kvs @@ -2402,15 +2403,15 @@ all_tcbs = mkNamedTyConBinders Inferred inferred ++ mkNamedTyConBinders Specified specified - ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + ++ map (mkExplicitTyConBinder mentioned_kv_set) tc_bndrs -- Eta expand if necessary; we are building a PolyTyCon ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind - ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ binderVars tc_bndrs) final_tcbs = all_tcbs `chkAppend` eta_tcbs tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs - True -- it is generalised + True -- Make a PolyTcTyCon, fully generalised flav ; reportUnsolvedEqualities skol_info (binderVars final_tcbs) @@ -2430,7 +2431,7 @@ , text "scoped_kvs" <+> ppr scoped_kvs , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs , text "all_kinds" <+> ppr all_kinds - , text "tc_tvs" <+> pprTyVars tc_tvs + , text "tc_tvs" <+> pprTyVars (binderVars tc_bndrs) , text "res_kind" <+> ppr res_kind , text "inferred" <+> ppr inferred , text "specified" <+> ppr specified @@ -2445,27 +2446,37 @@ ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind +-- | Create a TyConBinder for a user-written type variable binder. +mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently + -> VarBndr TyVar (HsBndrVis GhcRn) + -> TyConBinder +mkExplicitTyConBinder dep_set (Bndr tv flag) = + case flag of + HsBndrRequired -> mkRequiredTyConBinder dep_set tv + HsBndrInvisible{} -> mkNamedTyConBinder Specified tv + -- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and -- other kinds). -- -- This function does not do telescope checking. kcInferDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + :: Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon + -> TcM ContextKind -- ^ The result kind + -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon kcInferDeclHeader name flav (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki + , hsq_explicit = hs_bndrs }) kc_res_ki -- No standalone kind signature and no CUSK. -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) + do { rejectInvisibleBinders name hs_bndrs + ; (scoped_kvs, (tc_bndrs, res_kind)) -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - <- bindImplicitTKBndrs_Q_Tv kv_ns $ - bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ + <- bindImplicitTKBndrs_Q_Tv kv_ns $ + bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs $ newExpectedKind =<< kc_res_ki -- Why "_Tv" not "_Skol"? See third wrinkle in -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, @@ -2475,12 +2486,17 @@ -- recursive group. -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + tc_tvs = binderVars tc_bndrs + -- Discard visibility flags. We made sure all of them are HsBndrRequired + -- by the call to rejectInvisibleBinders above. + tc_binders = mkAnonTyConBinders tc_tvs - -- Also, note that tc_binders has the tyvars from only the - -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] - -- in GHC.Tc.TyCl + -- This has to be mkAnonTyConBinder! + -- See Note [No polymorphic recursion in type decls] in GHC.Tc.TyCl -- - -- mkAnonTyConBinder: see Note [No polymorphic recursion] + -- Also, note that tc_binders has the tyvars from only the + -- user-written type variable binders. + -- See S1 Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) -- NB: bindExplicitTKBndrs_Q_Tv does not clone; @@ -2488,11 +2504,11 @@ -- See Note [Cloning for type variable binders] tycon = mkTcTyCon name tc_binders res_kind all_tv_prs - False -- not yet generalised + False -- Make a MonoTcTyCon flav ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_tvs + vcat [ ppr name, ppr kv_ns, ppr hs_bndrs , ppr scoped_kvs , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] ; return tycon } @@ -2500,15 +2516,26 @@ ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind +-- rejectInvisibleBinders is called on on the inference code path; there is +-- no standalone kind signature, nor CUSK. +-- See Note [No inference for invisible binders in type decls] in GHC.Tc.TyCl +rejectInvisibleBinders :: Name -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcM () +rejectInvisibleBinders name = mapM_ check_bndr_vis + where + check_bndr_vis :: LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcM () + check_bndr_vis bndr = + when (isHsBndrInvisible (hsTyVarBndrFlag (unLoc bndr))) $ + addErr (TcRnInvisBndrWithoutSig name bndr) + -- | Kind-check a declaration header against a standalone kind signature. -- See Note [kcCheckDeclHeader_sig] kcCheckDeclHeader_sig - :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon + :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon -- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki): -- kind(returned PolyTcTyCon) = sig_kind -- @@ -2529,20 +2556,19 @@ ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind)))) <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone - matchUpSigWithDecl sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> + matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> do { -- Kind-check the result kind annotation, if present: -- data T a b :: res_ki where ... -- ^^^^^^^^^ -- We do it here because at this point the environment has been -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; res_kind :: ContextKind <- kc_res_ki - + ; ctx_k <- kc_res_ki -- Work out extra_arity, the number of extra invisible binders from -- the kind signature that should be part of the TyCon's arity. -- See Note [Arity inference in kcCheckDeclHeader_sig] ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs - invis_arity = case res_kind of + invis_arity = case ctx_k of AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders -- the signature into part of the arity of the TyCon OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the @@ -2556,9 +2582,12 @@ , ppr invis_arity, ppr invis_tcbs , ppr n_invis_tcbs ] - -- Unify res_ki (from the type declaration) with - -- sig_res_kind', the residual kind from the kind signature. - ; checkExpectedResKind sig_res_kind' res_kind + -- Unify res_ki (from the type declaration) with the residual kind from + -- the kind signature. Don't forget to apply the skolemising 'subst' first. + ; case ctx_k of + AnyKind -> return () -- No signature + _ -> do { res_ki <- newExpectedKind ctx_k + ; discardResult (unifyKind Nothing sig_res_kind' res_ki) } -- Add more binders for data/newtype, so the result kind has no arrows -- See Note [Datatype return kinds] @@ -2578,10 +2607,9 @@ -- Here p and q both map to the same kind variable k. We don't allow this -- so we must check that they are distinct. A similar thing happens -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference. - ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs + ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs ; let implicit_prs = implicit_nms `zip` implicit_tvs ; checkForDuplicateScopedTyVars implicit_prs - ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs -- Swizzle the Names so that the TyCon uses the user-declared implicit names -- E.g type T :: k -> Type @@ -2595,11 +2623,11 @@ all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) ; traceTc "kcCheckDeclHeader swizzle" $ vcat - [ text "sig_tcbs =" <+> ppr sig_tcbs - , text "implicit_prs =" <+> ppr implicit_prs - , text "hs_tv_bndrs =" <+> ppr hs_tv_bndrs - , text "all_tcbs =" <+> pprTyVars (binderVars all_tcbs) - , text "swizzled_tcbs =" <+> pprTyVars (binderVars swizzled_tcbs) + [ text "implicit_prs = " <+> ppr implicit_prs + , text "implicit_nms = " <+> ppr implicit_nms + , text "hs_tv_bndrs = " <+> ppr hs_tv_bndrs + , text "all_tcbs = " <+> pprTyVars (binderVars all_tcbs) + , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs) , text "tycon_res_kind =" <+> ppr tycon_res_kind , text "swizzled_kind =" <+> ppr swizzled_kind ] @@ -2607,7 +2635,9 @@ -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs -- because the tv_prs is used when (say) typechecking the RHS of -- a type synonym. - ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs True flav + ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs + True -- Make a PolyTcTyCon, fully generalised + flav ; traceTc "kcCheckDeclHeader_sig }" $ vcat [ text "tyConName = " <+> ppr (tyConName tc) @@ -2618,31 +2648,11 @@ ] ; return tc } --- | Check the result kind annotation on a type constructor against --- the corresponding section of the standalone kind signature. --- Drops invisible binders that interfere with unification. -checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature - -> ContextKind -- ^ the result kind from the declaration header - -> TcM () -checkExpectedResKind _ AnyKind - = return () -- No signature in the declaration header -checkExpectedResKind sig_kind res_ki - = do { actual_res_ki <- newExpectedKind res_ki - - ; let -- Drop invisible binders from sig_kind until they match up - -- with res_ki. By analogy with checkExpectedKind. - n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_kind - n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs - - (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind - - ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki } - matchUpSigWithDecl - :: [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature + :: Name -- Name of the type constructor for error messages + -> [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature -> TcKind -- The tail end of the kind signature - -> [LHsTyVarBndr () GhcRn] -- User-written binders in decl + -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -- User-written binders in decl -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope -- Argument is excess TyConBinders and tail kind -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars @@ -2650,7 +2660,7 @@ -- See Note [Matching a kind signature with a declaration] -- Invariant: Length of returned TyConBinders + length of excess TyConBinders -- = length of incoming TyConBinders -matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside +matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside = go emptySubst sig_tcbs hs_bndrs where go subst tcbs [] @@ -2661,23 +2671,22 @@ go _ [] hs_bndrs = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs) - go subst (tcb : tcbs') hs_bndrs - | Bndr tv vis <- tcb - , isVisibleTcbVis vis - , (L _ hs_bndr : hs_bndrs') <- hs_bndrs -- hs_bndrs is non-empty + go subst (tcb : tcbs') hs_bndrs@(hs_bndr : hs_bndrs') + | zippable (binderFlag tcb) (hsTyVarBndrFlag (unLoc hs_bndr)) = -- Visible TyConBinder, so match up with the hs_bndrs - do { let tv' = updateTyVarKind (substTy subst) $ + do { let Bndr tv vis = tcb + tv' = updateTyVarKind (substTy subst) $ setTyVarName tv (getName hs_bndr) -- Give the skolem the Name of the HsTyVarBndr, so that if it -- appears in an error message it has a name and binding site -- that come from the type declaration, not the kind signature subst' = extendTCvSubstWithClone subst tv tv' - ; tc_hs_bndr hs_bndr (tyVarKind tv') + ; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv') ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $ go subst' tcbs' hs_bndrs' ; return (Bndr tv' vis : tcbs', res) } - | otherwise + | skippable (binderFlag tcb) = -- Invisible TyConBinder, so do not consume one of the hs_bndrs do { let (subst', tcb') = substTyConBinderX subst tcb ; (tcbs', res) <- go subst' tcbs' hs_bndrs @@ -2685,7 +2694,14 @@ -- HsTyVarBndr for an invisible TyConBinder ; return (tcb' : tcbs', res) } - tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM () + | otherwise = + -- At this point we conclude that: + -- * the quantifier (tcb) is visible: (ty -> ...), (forall a -> ...) + -- * the binder (hs_bndr) is invisible: @t, @(t :: k) + -- Any other combination should have been handled by the zippable/skippable clauses. + failWithTc (TcRnInvalidInvisTyVarBndr name hs_bndr) + + tc_hs_bndr :: HsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcKind -> TcM () tc_hs_bndr (UserTyVar _ _ _) _ = return () tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind @@ -2693,6 +2709,17 @@ ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } + -- See GHC Proposal #425, section "Kind checking", + -- where zippable and skippable are defined. + zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool + zippable vis HsBndrRequired = isVisibleTcbVis vis + zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis + + -- See GHC Proposal #425, section "Kind checking", + -- where zippable and skippable are defined. + skippable :: TyConBndrVis -> Bool + skippable vis = not (isVisibleTcbVis vis) + substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder) substTyConBinderX subst (Bndr tv vis) = (subst', Bndr tv' vis) @@ -2732,7 +2759,7 @@ NB: these TyConBinders contain TyVars, not TcTyVars. * matchUpSigWithDecl: match the [TyConBinder] from the signature with - the [LHsTyVarBndr () GhcRn] from the declaration. The latter are the + the [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] from the declaration. The latter are the explicit, user-written binders. e.g. data T (a :: k) b = .... There may be more of the former than the latter, because the former @@ -2881,55 +2908,7 @@ This (Id Bool) will not show up anywhere after we're done validating it, so we have no use for the produced coercion. --} -{- Note [No polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should this kind-check? - data T ka (a::ka) b = MkT (T Type Int Bool) - (T (Type -> Type) Maybe Bool) - -Notice that T is used at two different kinds in its RHS. No! -This should not kind-check. Polymorphic recursion is known to -be a tough nut. - -Previously, we laboriously (with help from the renamer) -tried to give T the polymorphic kind - T :: forall ka -> ka -> kappa -> Type -where kappa is a unification variable, even in the inferInitialKinds -phase (which is what kcInferDeclHeader is all about). But -that is dangerously fragile (see the ticket). - -Solution: make kcInferDeclHeader give T a straightforward -monomorphic kind, with no quantification whatsoever. That's why -we use mkAnonTyConBinder for all arguments when figuring out -tc_binders. - -But notice that (#16322 comment:3) - -* The algorithm successfully kind-checks this declaration: - data T2 ka (a::ka) = MkT2 (T2 Type a) - - Starting with (inferInitialKinds) - T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * - we get - kappa4 := kappa1 -- from the (a:ka) kind signature - kappa1 := Type -- From application T2 Type - - These constraints are soluble so generaliseTcTyCon gives - T2 :: forall (k::Type) -> k -> * - - But now the /typechecking/ (aka desugaring, tcTyClDecl) phase - fails, because the call (T2 Type a) in the RHS is ill-kinded. - - We'd really prefer all errors to show up in the kind checking - phase. - -* This algorithm still accepts (in all phases) - data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) - although T3 is really polymorphic-recursive too. - Perhaps we should somehow reject that. - Note [Kind variable ordering for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What should be the kind of `T` in the following example? (#15591) @@ -3006,25 +2985,6 @@ * * ********************************************************************* -} -checkForDisconnectedScopedTyVars :: TyConFlavour -> [TcTyConBinder] - -> [(Name,TcTyVar)] -> TcM () --- See Note [Disconnected type variables] --- `scoped_prs` is the mapping gotten by unifying --- - the standalone kind signature for T, with --- - the header of the type/class declaration for T -checkForDisconnectedScopedTyVars flav sig_tcbs scoped_prs - = when (needsEtaExpansion flav) $ - -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables] - mapM_ report_disconnected (filterOut ok scoped_prs) - where - sig_tvs = mkVarSet (binderVars sig_tcbs) - ok (_, tc_tv) = tc_tv `elemVarSet` sig_tvs - - report_disconnected :: (Name,TcTyVar) -> TcM () - report_disconnected (nm, _) - = setSrcSpan (getSrcSpan nm) $ - addErrTc $ TcRnDisconnectedTyVar nm - checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () -- Check for duplicates -- E.g. data SameKind (a::k) (b::k) @@ -3055,64 +3015,6 @@ addErrTc $ TcRnDifferentNamesForTyVar n1 n2 -{- Note [Disconnected type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note applies when kind-checking the header of a type/class decl that has -a separate, standalone kind signature. See #24083. - -Consider: - type S a = Type - - type C :: forall k. S k -> Constraint - class C (a :: S kk) where - op :: ...kk... - -Note that the class has a separate kind signature, so the elaborated decl should -look like - class C @kk (a :: S kk) where ... - -But how can we "connect up" the scoped variable `kk` with the skolem kind from the -standalone kind signature for `C`? In general we do this by unifying the two. -For example - type T k = (k,Type) - type W :: forall k. T k -> Type - data W (a :: (x,Type)) = ..blah blah.. - -When we encounter (a :: (x,Type)) we unify the kind (x,Type) with the kind (T k) -from the standalone kind signature. Of course, unification looks through synonyms -so we end up with the mapping [x :-> k] that connects the scoped type variable `x` -with the kind from the signature. - -But in our earlier example this unification is ineffective -- because `S` is a -phantom synonym that just discards its argument. So our plan is this: - - if matchUpSigWithDecl fails to connect `kk with `k`, by unification, - we give up and complain about a "disconnected" type variable. - -See #24083 for dicussion of alternatives, none satisfactory. Also the fix is -easy: just add an explicit `@kk` parameter to the declaration, to bind `kk` -explicitly, rather than binding it implicitly via unification. - -(DTV1) We only want to make this check when there /are/ scoped type variables; and - that is determined by needsEtaExpansion. Examples: - - type C :: x -> y -> Constraint - class C a :: b -> Constraint where { ... } - -- The a,b scope over the "..." - - type D :: forall k. k -> Type - data family D :: kk -> Type - -- Nothing for `kk` to scope over! - - In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will - return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do - the check-for-disconnected-tyvars check we'll complain that `kk` is not bound - to one of `all_tcbs` (see #24083, comments about the `singletons` package). - - The scoped-tyvar stuff is needed precisely for data/class/newtype declarations, - where needsEtaExpansion is True. --} - {- ********************************************************************* * * Bringing type variables into scope @@ -3152,7 +3054,7 @@ -- HsOuterTyVarBndrs -------------------------------------- -bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed +bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc => SkolemMode -> HsOuterTyVarBndrs flag GhcRn -> TcM a @@ -3229,7 +3131,7 @@ -- sm_clone=False: see Note [Cloning for type variable binders] --------------- -tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed +tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc => SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) @@ -3240,7 +3142,7 @@ -- Do not clone the outer binders -- See Note [Cloning for type variable binders] under "must not" -tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed +tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc => SkolemMode -> SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) @@ -3261,7 +3163,7 @@ -- Explicit tyvar binders -------------------------------------- -tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed +tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc => SkolemInfo -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3269,7 +3171,7 @@ tcExplicitTKBndrs skol_info = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) -tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed +tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3304,14 +3206,14 @@ -- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied -- 'TcTyMode'. bindExplicitTKBndrs_Skol - :: (OutputableBndrFlag flag 'Renamed) + :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc => SkolemInfo -> [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) bindExplicitTKBndrs_Tv - :: (OutputableBndrFlag flag 'Renamed) + :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) @@ -3321,33 +3223,34 @@ -- sm_clone: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Skol - :: SkolemInfo + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => SkolemInfo -> ContextKind - -> [LHsTyVarBndr () GhcRn] + -> [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([TcTyVar], a) + -> TcM ([VarBndr TyVar flag], a) bindExplicitTKBndrs_Q_Tv - :: ContextKind - -> [LHsTyVarBndr () GhcRn] + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => ContextKind + -> [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([TcTyVar], a) + -> TcM ([VarBndr TyVar flag], a) -- These do not clone: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside - = mapFst binderVars $ - bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside - = mapFst binderVars $ - bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] -bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed) +bindExplicitTKBndrsX + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3600,9 +3503,10 @@ -- here we do it right away because there are no more unifications to come bindTyClTyVarsAndZonk tycon_name thing_inside = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind -> - do { ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; kind <- zonkTcTypeToTypeX ze tc_kind + do { (bndrs, kind) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { kind <- zonkTcTypeToTypeX tc_kind + ; return (bndrs, kind) } ; thing_inside bndrs kind } @@ -3614,7 +3518,7 @@ zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs + = do { spec_tkvs <- liftZonkM $ zonkTcTyVarsToTcTyVars spec_tkvs -- Zonk the kinds, to we can do the dependency analysis -- Do a stable topological sort, following @@ -3652,8 +3556,12 @@ -- here will already have all type variables quantified; -- thus, every free variable is really a kv, never a tv. ; dvs <- candidateQTyVarsOfKind kind_or_type - ; dvs <- filterConstrainedCandidates wanted dvs - ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } + ; filtered_dvs <- filterConstrainedCandidates wanted dvs + ; traceTc "kindGeneralizeSome" $ + vcat [ text "type:" <+> ppr kind_or_type + , text "dvs:" <+> ppr dvs + , text "filtered_dvs:" <+> ppr filtered_dvs ] + ; quantifyTyVars skol_info DefaultNonStandardTyVars filtered_dvs } filterConstrainedCandidates :: WantedConstraints -- Don't quantify over variables free in these @@ -3669,7 +3577,7 @@ | isEmptyWC wanted -- Fast path for a common case = return dvs | otherwise - = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) + = do { wc_tvs <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) ; _ <- promoteTyVarSet to_promote ; return dvs' } @@ -3762,7 +3670,7 @@ -} ----------------------------------- -etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo +etaExpandAlgTyCon :: TyConFlavour tc -> SkolemInfo -> [TcTyConBinder] -> Kind -> TcM ([TcTyConBinder], Kind) etaExpandAlgTyCon flav skol_info tcbs res_kind @@ -3775,7 +3683,7 @@ in_scope = mkInScopeSetList tyvars avoid_occs = map getOccName tyvars -needsEtaExpansion :: TyConFlavour -> Bool +needsEtaExpansion :: TyConFlavour tc -> Bool needsEtaExpansion NewtypeFlavour = True needsEtaExpansion DataTypeFlavour = True needsEtaExpansion ClassFlavour = True @@ -3797,14 +3705,13 @@ -- See also Note [Datatype return kinds] in GHC.Tc.TyCl splitTyConKind skol_info in_scope avoid_occs kind = do { loc <- getSrcSpanM - ; uniqs <- newUniqueSupply + ; new_uniqs <- getUniquesM ; rdr_env <- getLocalRdrEnv ; lvl <- getTcLevel ; let new_occs = Inf.filter (\ occ -> isNothing (lookupLocalRdrOcc rdr_env occ) && -- Note [Avoid name clashes for associated data types] not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings - new_uniqs = uniqsFromSupply uniqs subst = mkEmptySubst in_scope details = SkolemTv skol_info (pushTcLevel lvl) False -- As always, allocate skolems one level in @@ -3814,9 +3721,10 @@ Nothing -> (reverse acc, substTy subst kind) Just (Anon arg af, kind') - -> go occs' uniqs' subst' (tcb : acc) kind' + -> assert (af == FTF_T_T) $ + go occs' uniqs' subst' (tcb : acc) kind' where - tcb = Bndr tv (AnonTCB af) + tcb = Bndr tv AnonTCB arg' = substTy subst (scaledThing arg) name = mkInternalName uniq occ loc tv = mkTcTyVar name arg' details @@ -3957,7 +3865,8 @@ go fun_kind subst all_args@(arg : args) | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind = case tcb of - Anon _ af -> AnonTCB af : go inner_kind subst args + Anon _ af -> assert (af == FTF_T_T) $ + AnonTCB : go inner_kind subst args Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args where subst' = extendTCvSubst subst tv arg @@ -4104,9 +4013,11 @@ -- Zonk, so that any nested foralls can "see" their occurrences -- See Note [Checking partial type signatures], and in particular -- Note [Levels for wildcards] - ; tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs') - ; theta <- mapM zonkTcType (theta ++ theta') - ; tau <- zonkTcType tau + ; (tv_prs, theta, tau) <- liftZonkM $ + do { tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs') + ; theta <- mapM zonkTcType (theta ++ theta') + ; tau <- zonkTcType tau + ; return (tv_prs, theta, tau) } -- NB: checkValidType on the final inferred type will be -- done later by checkInferredPolyId. We can't do it @@ -4299,7 +4210,7 @@ -- to a's kind, which will be a metavariable. -- kindGeneralizeNone does this: ; kindGeneralizeNone sig_ty - ; sig_ty <- zonkTcType sig_ty + ; sig_ty <- liftZonkM $ zonkTcType sig_ty ; checkValidType ctxt sig_ty ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) @@ -4404,7 +4315,7 @@ ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) -- No generalization: ; kindGeneralizeNone kind - ; kind <- zonkTcType kind + ; kind <- liftZonkM $ zonkTcType kind -- This zonk is very important in the case of higher rank kinds -- E.g. #13879 f :: forall (p :: forall z (y::z). ). -- @@ -4438,7 +4349,7 @@ 2 (quotes (ppr arg)) -- | Add a "In the data declaration for T" or some such. -addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a +addTyConFlavCtxt :: Name -> TyConFlavour tc -> TcM a -> TcM a addTyConFlavCtxt name flav = addErrCtxt $ hsep [ text "In the", ppr flav , text "declaration for", quotes (ppr name) ] 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 @@ -42,6 +42,7 @@ , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr ) +import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPatRn ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env @@ -69,7 +70,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Driver.Session ( getDynFlags ) +import GHC.Driver.DynFlags ( getDynFlags ) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name @@ -473,21 +474,28 @@ ; thing <- thing_inside elt_ty ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } --- ParStmt: See notes with tcMcStmt +-- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions] tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s + = do { env <- getLocalRdrEnv + ; (pairs', thing) <- loop env [] bndr_stmts_s ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } where - -- loop :: [([LStmt GhcRn], [GhcRn])] + -- loop :: LocalRdrEnv -- The original LocalRdrEnv + -- -> [Name] -- Variables bound by earlier branches + -- -> [([LStmt GhcRn], [GhcRn])] -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches + -- + -- Invariant: on entry to `loop`, the LocalRdrEnv is set to + -- origEnv, the LocalRdrEnv for the entire comprehension + loop _ allBinds [] = do { thing <- bindLocalNames allBinds $ thing_inside elt_ty + ; return ([], thing) } -- matching in the branches - loop (ParStmtBlock x stmts names _ : pairs) + loop origEnv priorBinds (ParStmtBlock x stmts names _ : pairs) = do { (stmts', (ids, pairs', thing)) <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> do { ids <- tcLookupLocalIds names - ; (pairs', thing) <- loop pairs + ; (pairs', thing) <- setLocalRdrEnv origEnv $ + loop origEnv (names ++ priorBinds) pairs ; return (ids, pairs', thing) } ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } @@ -980,7 +988,7 @@ -- yet determined. tcMonadFailOp orig pat fail_op res_ty = do dflags <- getDynFlags - if isIrrefutableHsPat dflags pat + if isIrrefutableHsPatRn dflags pat then return Nothing else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] (mkCheckExpType res_ty) $ \_ _ -> return ()) @@ -1012,6 +1020,21 @@ <$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 <*>_i :: t_(i-1) -> exp_ty_i -> t_i join :: tn -> res_ty + +Note [Scoping in parallel list comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a parallel list comprehension like [ ebody | a <- blah1; e1 | b <- blah2; e2 ] +we want to ensure that in the lexical environment, tcl_rdr :: LocalRdrEnv, we have + * 'a' in scope in e1, but not 'b' + * 'b' in scope in e2, but not 'a' + * Both in scope in ebody +We don't want too /many/ variables in the LocalRdrEnv, else we make stupid +suggestions for an out-of-scope variable (#22940). + +To achieve this we: + * At the start of each branch, reset the LocalRdrEnv to the outer scope. + * Before typechecking ebody, add to LocalRdrEnv all the variables bound in + all branches. This step is done with bindLocalNames. -} tcApplicativeStmts 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 @@ -31,7 +31,6 @@ import GHC.Hs.Syn.Type import GHC.Rename.Utils import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate @@ -44,7 +43,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Validity( arityErr ) +import GHC.Tc.Zonk.TcType import GHC.Core.TyCo.Ppr ( pprTyVars ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify @@ -60,7 +59,7 @@ import GHC.Core.ConLike import GHC.Builtin.Names import GHC.Types.Basic hiding (SuccessFlag(..)) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Utils.Misc @@ -1113,7 +1112,7 @@ This is achieve easily, but a bit trickily. When we instantiate Annotated's "required" constraints, in tcPatSynPat, give them a CtOrigin of (OccurrenceOf "Annotated"). That way the special magic -in GHC.Tc.Solver.Canonical.canClassNC which deals with CallStack +in GHC.Tc.Solver.Dict.solveCallStack which deals with CallStack constraints will kick in: that logic only fires on constraints whose Origin is (OccurrenceOf f). @@ -1329,7 +1328,7 @@ -- NB: type_args already dealt with -- See Note [Type applications in patterns] { checkTc (con_arity == no_of_args) -- Check correct arity - (arityErr (text "constructor") con_like con_arity no_of_args) + (TcRnArityMismatch (AConLike con_like) con_arity no_of_args) ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys thing_inside @@ -1341,7 +1340,7 @@ InfixCon p1 p2 -> do { checkTc (con_arity == 2) -- Check correct arity - (arityErr (text "constructor") con_like con_arity 2) + (TcRnArityMismatch (AConLike 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 penv [(p1,arg_ty1),(p2,arg_ty2)] thing_inside 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 @@ -24,6 +24,7 @@ import GHC.Tc.Gen.Expr import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify( buildImplicationFor ) +import GHC.Tc.Zonk.TcType import GHC.Core.Type import GHC.Core.Coercion( mkCoVarCo ) @@ -133,7 +134,7 @@ , ppr lhs_wanted , ppr rhs_wanted ]) - ; (lhs_evs, residual_lhs_wanted) + ; (lhs_evs, residual_lhs_wanted, dont_default) <- simplifyRule name tc_lvl lhs_wanted rhs_wanted -- SimplifyRule Plan, step 4 @@ -147,21 +148,20 @@ -- -- We also need to get the completely-unconstrained tyvars of -- the LHS, lest they otherwise get defaulted to Any; but we do that - -- during zonking (see GHC.Tc.Utils.Zonk.zonkRule) + -- during zonking (see GHC.Tc.Zonk.Type.zonkRule) ; let tpl_ids = lhs_evs ++ id_bndrs -- See Note [Re-quantify type variables in rules] ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) - ; let don't_default = nonDefaultableTyVarsOfWC residual_lhs_wanted - ; let weed_out = (`dVarSetMinusVarSet` don't_default) + ; let weed_out = (`dVarSetMinusVarSet` dont_default) quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs) , dv_tvs = weed_out (dv_tvs forall_tkvs) } ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname , text "forall_tkvs:" <+> ppr forall_tkvs , text "quant_cands:" <+> ppr quant_cands - , text "don't_default:" <+> ppr don't_default + , text "dont_default:" <+> ppr dont_default , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted , text "qtkvs:" <+> ppr qtkvs , text "rule_ty:" <+> ppr rule_ty @@ -401,7 +401,8 @@ -> WantedConstraints -- Constraints from LHS -> WantedConstraints -- Constraints from RHS -> TcM ( [EvVar] -- Quantify over these LHS vars - , WantedConstraints) -- Residual un-quantified LHS constraints + , WantedConstraints -- Residual un-quantified LHS constraints + , TcTyVarSet ) -- Don't default these -- See Note [The SimplifyRule Plan] -- NB: This consumes all simple constraints on the LHS, but not -- any LHS implication constraints. @@ -413,17 +414,26 @@ -- Why clone? See Note [Simplify cloned constraints] ; lhs_clone <- cloneWC lhs_wanted ; rhs_clone <- cloneWC rhs_wanted - ; setTcLevel tc_lvl $ - discardResult $ - runTcS $ - do { _ <- solveWanteds lhs_clone - ; _ <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - ; return () } + ; (dont_default, _) + <- setTcLevel tc_lvl $ + runTcS $ + do { lhs_wc <- solveWanteds lhs_clone + ; _rhs_wc <- solveWanteds rhs_clone + -- Why do them separately? + -- See Note [Solve order for RULES] + ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc + -- If lhs_wanteds has + -- (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc]) + -- we want r0 to be non-defaultable; + -- see nonDefaultableTyVarsOfWC. Simplest way to get + -- this is to look at the post-simplified lhs_wc, which + -- will contain (rr[sk] ~ r0[conc)]. An example is in + -- test rep-poly/RepPolyRule1 + ; return dont_default } + -- Note [The SimplifyRule Plan] step 2 - ; lhs_wanted <- zonkWC lhs_wanted + ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted -- Note [The SimplifyRule Plan] step 3 @@ -435,9 +445,10 @@ , text "rhs_wanted" <+> ppr rhs_wanted , text "quant_cts" <+> ppr quant_cts , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted + , text "dont_default" <+> ppr dont_default ] - ; return (quant_evs, residual_lhs_wanted) } + ; return (quant_evs, residual_lhs_wanted, dont_default) } where mk_quant_ev :: Ct -> TcM EvVar @@ -464,7 +475,7 @@ -- and attempt to solve them from the quantified constraints. That -- nearly works, but fails for a constraint like (d :: Eq Int). -- We /do/ want to quantify over it, but the short-cut solver --- (see GHC.Tc.Solver.Interact Note [Shortcut solving]) ignores the quantified +-- (see GHC.Tc.Solver.Dict Note [Shortcut solving]) ignores the quantified -- and instead solves from the top level. -- -- So we must partition the WantedConstraints ourselves 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 @@ -28,7 +28,7 @@ import GHC.Prelude import GHC.Data.FastString -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Backend import GHC.Hs @@ -40,7 +40,7 @@ import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep ) -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Validity ( checkValidType ) @@ -299,7 +299,7 @@ go (L _ ty) = case ty of HsWildCardTy _ -> False HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty ki -> go ty && go ki + HsAppKindTy _ ty _ ki -> go ty && go ki HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys @@ -442,14 +442,17 @@ -- These are /signatures/ so we zonk to squeeze out any kind -- unification variables. Do this after kindGeneralizeAll which may -- default kind variables to *. - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, kv_bndrs) <- zonkTyVarBindersX ze (mkTyVarBinders InferredSpec kvs) - ; (ze, implicit_bndrs) <- zonkTyVarBindersX ze implicit_bndrs - ; (ze, univ_bndrs) <- zonkTyVarBindersX ze univ_bndrs - ; (ze, ex_bndrs) <- zonkTyVarBindersX ze ex_bndrs - ; req <- zonkTcTypesToTypesX ze req - ; prov <- zonkTcTypesToTypesX ze prov - ; body_ty <- zonkTcTypeToTypeX ze body_ty + ; (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, req, prov, body_ty) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX (mkTyVarBinders InferredSpec kvs)) $ \ kv_bndrs -> + runZonkBndrT (zonkTyVarBindersX implicit_bndrs) $ \ implicit_bndrs -> + runZonkBndrT (zonkTyVarBindersX univ_bndrs) $ \ univ_bndrs -> + do { req <- zonkTcTypesToTypesX req + ; runZonkBndrT (zonkTyVarBindersX ex_bndrs) $ \ ex_bndrs -> + do { prov <- zonkTcTypesToTypesX prov + ; body_ty <- zonkTcTypeToTypeX body_ty + ; return (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, + req, prov, body_ty) } } -- Now do validity checking ; checkValidType ctxt $ @@ -513,12 +516,12 @@ tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst -- Instantiate a type signature; only used with plan InferGen -tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) +tcInstSig hs_sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Set the binding site of the tyvars do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id) -- See Note [Pattern bindings and complete signatures] - ; return (TISI { sig_inst_sig = sig + ; return (TISI { sig_inst_sig = hs_sig , sig_inst_skols = tv_prs , sig_inst_wcs = [] , sig_inst_wcx = Nothing 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 @@ -34,7 +34,7 @@ import GHC.Driver.Errors import GHC.Driver.Plugins import GHC.Driver.Main -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Hooks import GHC.Driver.Config.Diagnostic @@ -49,8 +49,10 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType import GHC.Tc.Solver import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.HsType @@ -92,7 +94,6 @@ import GHC.Core.ConLike import GHC.Core.DataCon as DataCon -import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -131,7 +132,6 @@ import GHC.Data.Maybe( MaybeErr(..) ) import qualified GHC.Data.EnumSet as EnumSet -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH @@ -145,7 +145,6 @@ import Control.Monad import Data.Binary import Data.Binary.Get -import Data.List ( find ) import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -155,6 +154,7 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) +import Data.IORef import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) @@ -793,7 +793,8 @@ -- Takes a m and tau and returns the type m (TExp tau) tcTExpTy :: TcType -> TcType -> TcM TcType tcTExpTy m_ty exp_ty - = do { unless (isTauTy exp_ty) $ addErr (TcRnTypedTHWithPolyType exp_ty) + = do { unless (isTauTy exp_ty) $ addErr $ + TcRnTHError $ TypedTHError $ TypedTHWithPolyType exp_ty ; codeCon <- tcLookupTyCon codeTyConName ; let rep = getRuntimeRep exp_ty ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } @@ -917,7 +918,7 @@ runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) = restoreLclEnv lcl_env $ - do { zonked_ty <- zonkTcType res_ty + do { zonked_ty <- liftZonkM $ zonkTcType res_ty ; zonked_q_expr <- zonkTopLExpr q_expr -- See Note [Collecting modFinalizers in typed splices]. ; modfinalizers_ref <- newTcRef [] @@ -962,7 +963,7 @@ spliceResultDoc :: LHsExpr GhcTc -> SDoc spliceResultDoc expr = sep [ text "In the result of the splice:" - , nest 2 (char '$' <> ppr expr) + , nest 2 (text "$$" <> ppr expr) , text "To see what the splice expanded to, use -ddump-splices"] stubNestedSplice :: HsExpr GhcTc @@ -1058,6 +1059,7 @@ withForeignRefs (x : xs) f = withForeignRef x $ \r -> withForeignRefs xs $ \rs -> f (r : rs) interp <- tcGetInterp + case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> do @@ -1065,17 +1067,18 @@ runQuasi $ sequence_ qs #endif - ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do + ExternalInterp ext -> withExtInterp ext $ \inst -> do tcg <- getGblEnv th_state <- readTcRef (tcg_th_remote_state tcg) case th_state of Nothing -> return () -- TH was not started, nothing to do Just fhv -> do - liftIO $ withForeignRef fhv $ \st -> + r <- liftIO $ withForeignRef fhv $ \st -> withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i + sendMessageDelayedResponse inst (RunModFinalizers st qrefs) + () <- runRemoteTH inst [] + qr <- liftIO $ receiveDelayedResponse inst r + checkQResult qr runQResult :: (a -> String) @@ -1250,7 +1253,8 @@ -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc (TcRnRunSpliceFailure Nothing err) + Left err -> failWithTc $ + TcRnTHError $ THSpliceFailed $ RunSpliceFailure err Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1265,8 +1269,8 @@ fail_with_exn :: Exception e => SplicePhase -> e -> TcM a fail_with_exn phase exn = do exn_msg <- liftIO $ Panic.safeShowException exn - failWithTc - $ TcRnSpliceThrewException phase (SomeException exn) exn_msg expr show_code + failWithTc $ TcRnTHError $ THSpliceFailed $ + SpliceThrewException phase (SomeException exn) exn_msg expr show_code {- Note [Running typed splices in the zonker] @@ -1382,8 +1386,8 @@ -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnReportCustomQuasiError True msg - qReport False msg = seqList msg $ addDiagnostic $ TcRnReportCustomQuasiError False msg + qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg + qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg qLocation :: TcM TH.Loc qLocation = do { m <- getModule @@ -1436,8 +1440,8 @@ th_origin <- getThSpliceOrigin let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of - Left exn -> failWithTc - $ TcRnRunSpliceFailure (Just "addTopDecls") exn + Left exn -> failWithTc $ TcRnTHError $ AddTopDeclsError $ + AddTopDeclsRunSpliceFailure exn Right ds -> return ds mapM_ (checkTopDecl . unLoc) ds th_topdecls_var <- fmap tcg_th_topdecls getGblEnv @@ -1453,7 +1457,7 @@ checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl d - = addErr $ TcRnInvalidTopDecl d + = addErr $ TcRnTHError $ AddTopDeclsError $ InvalidTopDecl d bindName :: RdrName -> TcM () bindName (Exact n) @@ -1461,7 +1465,7 @@ ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) } - bindName name = addErr $ TcRnNonExactName name + bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name qAddForeignFilePath lang fp = do var <- fmap tcg_th_foreign_files getGblEnv @@ -1479,7 +1483,7 @@ let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = TcRnAddInvalidCorePlugin plugin + let err = TcRnTHError $ AddInvalidCorePlugin plugin case r of Found {} -> addErr err FoundMultiple {} -> addErr err @@ -1507,7 +1511,7 @@ th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ TcRnAddDocToNonLocalDefn doc_loc + unless is_local $ failWithTc $ TcRnTHError $ AddDocToNonLocalDefn doc_loc let ds = mkGeneratedHsDocString s hd = lexHsDoc parseIdentifier ds hd' <- rnHsDoc hd @@ -1591,7 +1595,7 @@ Right (_, []) -> noMatches where noMatches = failWithTc $ - TcRnFailedToLookupThInstName th_type NoMatchesFound + TcRnTHError $ FailedToLookupThInstName th_type NoMatchesFound -- Get the name of the class for the instance we are documenting -- > inst_cls_name (Monad Maybe) == Monad @@ -1628,7 +1632,7 @@ inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err inst_cls_name_err = failWithTc $ - TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance + TcRnTHError $ FailedToLookupThInstName th_type CouldNotDetermineInstance -- Basically does the opposite of 'mkThAppTs' -- > inst_arg_types (Monad Maybe) == [Maybe] @@ -1691,37 +1695,40 @@ return r #endif - ExternalInterp conf iserv -> + ExternalInterp ext -> withExtInterp ext $ \inst -> do -- Run it on the server. For an overview of how TH works with -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. - withIServ_ conf iserv $ \i -> do - rstate <- getTHState i - loc <- TH.qLocation - liftIO $ - withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) - runRemoteTH i [] - bs <- readQResult i - return $! runGet get (LB.fromStrict bs) + rstate <- getTHState inst + loc <- TH.qLocation + -- run a remote TH request + r <- liftIO $ + withForeignRef rstate $ \state_hv -> + withForeignRef fhv $ \q_hv -> + sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc)) + -- respond to requests from the interpreter + runRemoteTH inst [] + -- get the final result + qr <- liftIO $ receiveDelayedResponse inst r + bs <- checkQResult qr + return $! runGet get (LB.fromStrict bs) -- | communicate with a remotely-running TH computation until it finishes. -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH - :: IServInstance + :: ExtInterpInstance d -> [Messages TcRnMessage] -- saved from nested calls to qRecover -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage +runRemoteTH inst recovers = do + THMsg msg <- liftIO $ receiveTHMessage inst case msg of RunTHDone -> return () StartRecover -> do -- Note [TH recover with -fexternal-interpreter] v <- getErrsVar msgs <- readTcRef v writeTcRef v emptyMessages - runRemoteTH iserv (msgs : recovers) + runRemoteTH inst (msgs : recovers) EndRecover caught_error -> do let (prev_msgs, rest) = case recovers of [] -> panic "EndRecover" @@ -1732,16 +1739,15 @@ writeTcRef v $ if caught_error then prev_msgs else mkMessages warn_msgs `unionMessages` prev_msgs - runRemoteTH iserv rest + runRemoteTH inst rest _other -> do r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers + liftIO $ sendAnyValue inst r + runRemoteTH inst recovers --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServInstance -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get +-- | Check a QResult +checkQResult :: QResult a -> TcM a +checkQResult qr = case qr of QDone a -> return a QException str -> liftIO $ throwIO (ErrorCall str) @@ -1788,17 +1794,18 @@ -- -- The TH state is stored in tcg_th_remote_state in the TcGblEnv. -- -getTHState :: IServInstance -> TcM (ForeignRef (IORef QState)) -getTHState i = do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Just rhv -> return rhv - Nothing -> do - interp <- tcGetInterp - fhv <- liftIO $ mkFinalizedHValue interp =<< iservCall i StartTH - writeTcRef (tcg_th_remote_state tcg) (Just fhv) - return fhv +getTHState :: ExtInterpInstance d -> TcM (ForeignRef (IORef QState)) +getTHState inst = do + th_state_var <- tcg_th_remote_state <$> getGblEnv + liftIO $ do + th_state <- readIORef th_state_var + case th_state of + Just rhv -> return rhv + Nothing -> do + rref <- sendMessage inst StartTH + fhv <- mkForeignRef rref (freeReallyRemoteRef inst rref) + writeIORef th_state_var (Just fhv) + return fhv wrapTHResult :: TcM a -> TcM (THResult a) wrapTHResult tcm = do @@ -1916,14 +1923,14 @@ ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out $ TcRnCannotReifyInstance ty } + _ -> bale_out $ TcRnTHError $ THReifyError $ CannotReifyInstance ty } where doc = ClassInstanceCtx bale_out msg = failWithTc msg cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc (TcRnRunSpliceFailure Nothing msg) + Left msg -> failWithTc (TcRnTHError $ THSpliceFailed $ RunSpliceFailure msg) Right ty -> return ty {- @@ -1938,7 +1945,7 @@ -- False <=> value namespace -> String -> TcM (Maybe TH.Name) lookupName is_type_name s - = do { mb_nm <- lookupOccRn_maybe rdr_name + = do { mb_nm <- lookupSameOccRn_maybe rdr_name ; return (fmap reifyName mb_nm) } where th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' @@ -1964,7 +1971,7 @@ getThSpliceOrigin :: TcM Origin getThSpliceOrigin = do warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated + if warn then return FromSource else return (Generated SkipPmc) getThing :: TH.Name -> TcM TcTyThing @@ -1975,9 +1982,10 @@ -- ToDo: this tcLookup could fail, which would give a -- rather unhelpful error message where - ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG (TH.FldName {}) _pkg _mod)) = text "fld" ppr_ns _ = panic "reify/ppr_ns" reify :: TH.Name -> TcM TH.Info @@ -1996,10 +2004,14 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name - = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name) + = do { let guesses = thRdrNameGuesses th_name + ; case guesses of + { [for_sure] -> lookupSameOccRn_maybe for_sure + ; _ -> + do { gres <- mapMaybeM lookupOccRn_maybe guesses -- Pick the first that works -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A - ; return (listToMaybe names) } + ; return (fmap greName $ listToMaybe gres) } } } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that @@ -2007,7 +2019,7 @@ -- tcLookup, failure is a bug. tcLookupTh name = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { + ; case lookupNameEnv (getLclEnvTypeEnv lcl_env) name of { Just thing -> return thing; Nothing -> @@ -2024,15 +2036,15 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + Failed msg -> failWithTc (TcRnInterfaceError msg) }}}} notInScope :: TH.Name -> TcRnMessage notInScope th_name = - TcRnCannotReifyOutOfScopeThing th_name + TcRnTHError $ THReifyError $ CannotReifyOutOfScopeThing th_name notInEnv :: Name -> TcRnMessage -notInEnv name = TcRnCannotReifyThingNotInTypeEnv name +notInEnv name = TcRnTHError $ THReifyError $ CannotReifyThingNotInTypeEnv name ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -2040,7 +2052,8 @@ = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing) + _ -> failWithTc $ TcRnTHError $ THReifyError $ + NoRolesAssociatedWithThing thing } where reify_role Nominal = TH.NominalR @@ -2057,10 +2070,8 @@ = do { ty <- reifyType (idType id) ; let v = reifyName id ; case idDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls)) - RecSelId{sel_tycon=RecSelData tc} - -> return (TH.VarI (reifySelector id tc) ty Nothing) - _ -> return (TH.VarI v ty Nothing) + ClassOpId cls _ -> return (TH.ClassOpI v ty (reifyName cls)) + _ -> return (TH.VarI v ty Nothing) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -2073,13 +2084,13 @@ ; return (TH.PatSynI name ty) } reifyThing (ATcId {tct_id = id}) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even + = do { ty1 <- liftZonkM $ zonkTcType (idType id) -- Make use of all the info we have, even -- though it may be incomplete ; ty2 <- reifyType ty1 ; return (TH.VarI (reifyName id) ty2 Nothing) } reifyThing (ATyVar tv tv1) - = do { ty1 <- zonkTcTyVar tv1 + = do { ty1 <- liftZonkM $ zonkTcTyVar tv1 ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } @@ -2135,7 +2146,7 @@ injRHS = map (reifyName . tyVarName) (filterByList ms tvs) in (sig, inj) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; tvs' <- reifyTyConBinders tc ; let tfHead = TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity ; if isOpenTypeFamilyTyCon tc @@ -2156,7 +2167,7 @@ ; kind' <- fmap Just (reifyKind res_kind) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; tvs' <- reifyTyConBinders tc ; fam_envs <- tcGetFamInstEnvs ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) ; return (TH.FamilyI @@ -2164,7 +2175,7 @@ | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; tvs' <- reifyTyConBinders tc ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) } @@ -2182,7 +2193,7 @@ dataCons = tyConDataCons tc isGadt = isGadtSyntaxTyCon tc ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) + ; r_tvs <- reifyTyConBinders tc ; let name = reifyName tc deriv = [] -- Don't know about deriving decl | isTypeDataTyCon tc = @@ -2232,7 +2243,7 @@ | not (null fields) -> do { res_ty <- reifyType g_res_ty ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) + (zip3 (map reifyFieldLabel fields) dcdBangs r_arg_tys) res_ty } -- We need to check not isGadtDataCon here because GADT -- constructors can be declared infix. @@ -2244,7 +2255,8 @@ ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } | isGadtDataCon -> do { res_ty <- reifyType g_res_ty - ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } + ; return $ TH.GadtC [name] + (dcdBangs `zip` r_arg_tys) res_ty } | otherwise -> return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) @@ -2310,7 +2322,7 @@ ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) ; assocTys <- concatMapM reifyAT ats ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) + ; tvs' <- reifyTyConBinders (classTyCon cls) ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) ; return (TH.ClassI dec insts) } where @@ -2502,6 +2514,7 @@ Overlapping _ -> Just TH.Overlapping Overlaps _ -> Just TH.Overlaps Incoherent _ -> Just TH.Incoherent + NonCanonical _ -> Just TH.Incoherent ------------------------------ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] @@ -2654,6 +2667,43 @@ reifyFlag SpecifiedSpec = TH.SpecifiedSpec reifyFlag InferredSpec = TH.InferredSpec +instance ReifyFlag TyConBndrVis (Maybe TH.BndrVis) where + reifyFlag AnonTCB = Just TH.BndrReq + reifyFlag (NamedTCB Required) = Just TH.BndrReq + reifyFlag (NamedTCB (Invisible _)) = + Nothing -- See Note [Reifying invisible type variable binders] and #22828. + +-- Currently does not return invisible type variable binders (@k-binders). +-- See Note [Reifying invisible type variable binders] and #22828. +reifyTyConBinders :: TyCon -> TcM [TH.TyVarBndr TH.BndrVis] +reifyTyConBinders tc = fmap (mapMaybe get_bndr) (reifyTyVarBndrs (tyConBinders tc)) + where + get_bndr :: TH.TyVarBndr (Maybe flag) -> Maybe (TH.TyVarBndr flag) + get_bndr = sequenceA + +{- Note [Reifying invisible type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In reifyFlag for TyConBndrVis, we have the following clause: + + reifyFlag (NamedTCB (Invisible _)) = Nothing + +This means that reifyTyConBinders doesn't reify invisible type variables as +@k-binders. However, it is possible (and not hard) to change this. +Just replace the above clause with: + + reifyFlag (NamedTCB Specified) = Just TH.BndrInvis + reifyFlag (NamedTCB Inferred) = Nothing -- Inferred variables can not be bound + +There are two reasons we opt not to do that for now. + 1. It would be a (sometimes silent) breaking change affecting th-abstraction, + aeson, and other libraries that assume that reified binders are visible. + 2. It would create an asymmetry with visible kind applications, which are + not reified either. + +This decision is not set in stone. If a use case for reifying invisible type +variable binders presents itself, we can reconsider. See #22828. +-} + reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] reifyTyVars = reifyTyVarBndrs . map mk_bndr where @@ -2734,26 +2784,12 @@ mk_varg | OccName.isDataOcc occ = TH.mkNameG_d | OccName.isVarOcc occ = TH.mkNameG_v | OccName.isTcOcc occ = TH.mkNameG_tc + | Just con_fs <- OccName.fieldOcc_maybe occ + = \ pkg mod occ -> TH.mkNameG_fld pkg mod (unpackFS con_fs) occ | otherwise = pprPanic "reifyName" (ppr name) --- See Note [Reifying field labels] reifyFieldLabel :: FieldLabel -> TH.Name -reifyFieldLabel fl - | flIsOverloaded fl - = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) - | otherwise = TH.mkNameG_v pkg_str mod_str occ_str - where - name = flSelector fl - mod = assert (isExternalName name) $ nameModule name - pkg_str = unitString (moduleUnit mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (field_label $ flLabel fl) - -reifySelector :: Id -> TyCon -> TH.Name -reifySelector id tc - = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of - Just fl -> reifyFieldLabel fl - Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) +reifyFieldLabel fl = reifyName $ flSelector fl ------------------------------ reifyFixity :: Name -> TcM (Maybe TH.Fixity) @@ -2795,8 +2831,8 @@ reifyType (idType (dataConWrapId dc)) AGlobal (AConLike (PatSynCon ps)) -> reifyPatSynType (patSynSigBndr ps) - ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType - ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType + ATcId{tct_id = id} -> liftZonkM (zonkTcType (idType id)) >>= reifyType + ATyVar _ tctv -> liftZonkM (zonkTcTyVar tctv) >>= reifyType -- Impossible cases, supposedly: AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" @@ -2852,38 +2888,10 @@ mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys noTH :: UnrepresentableTypeDescr -> Type -> TcM a -noTH s d = failWithTc $ TcRnCannotRepresentType s d +noTH s d = failWithTc $ TcRnTHError $ THReifyError $ CannotRepresentType s d ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) - -{- -Note [Reifying field labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reifying a datatype declared with DuplicateRecordFields enabled, we want -the reified names of the fields to be labels rather than selector functions. -That is, we want (reify ''T) and (reify 'foo) to produce - - data T = MkT { foo :: Int } - foo :: T -> Int - -rather than - - data T = MkT { $sel:foo:MkT :: Int } - $sel:foo:MkT :: T -> Int - -because otherwise TH code that uses the field names as strings will silently do -the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather -than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the -environment, NameG can't be used to represent such fields. Instead, -reifyFieldLabel uses NameQ. - -However, this means that extracting the field name from the output of reify, and -trying to reify it again, may fail with an ambiguity error if there are multiple -such fields defined in the module (see the test case -overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to -the TH AST to make it able to represent duplicate record fields. --} tcGetInterp :: TcM Interp tcGetInterp = do 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 @@ -2,15 +2,15 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.Instance.Class ( - matchGlobalInst, + matchGlobalInst, matchEqualityInst, ClsInstResult(..), InstanceWhat(..), safeOverlap, instanceReturnsDictCon, - AssocInstInfo(..), isNotAssociated, + AssocInstInfo(..), isNotAssociated ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.TyCo.Rep @@ -21,20 +21,20 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) -import GHC.Rename.Env( addUsedGRE ) +import GHC.Rename.Env( addUsedGRE, DeprecationWarnings (..) ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Types.FieldLabel -import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName ) +import GHC.Types.Name.Reader import GHC.Types.SafeHaskell -import GHC.Types.Name ( Name, pprDefinedAt ) +import GHC.Types.Name ( Name ) import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id -import GHC.Types.Id.Make ( nospecId ) import GHC.Types.Var import GHC.Core.Predicate @@ -46,7 +46,7 @@ import GHC.Core.TyCon import GHC.Core.Class -import GHC.Core ( Expr(Var, App, Cast, Type) ) +import GHC.Core ( Expr(Var, App, Cast) ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -87,39 +87,19 @@ * * **********************************************************************-} --- | Indicates if Instance met the Safe Haskell overlapping instances safety --- check. --- --- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -type SafeOverlapping = Bool - data ClsInstResult = NoInstance -- Definitely no instance - | OneInst { cir_new_theta :: [TcPredType] - , cir_mk_ev :: [EvExpr] -> EvTerm - , cir_what :: InstanceWhat } + | OneInst { cir_new_theta :: [TcPredType] + , cir_mk_ev :: [EvExpr] -> EvTerm + , cir_canonical :: Canonical -- cir_canonical=True => you can specialise on this instance + -- cir_canonical= False => you cannot specialise on this instance + -- (its OverlapFlag is NonCanonical) + -- See Note [Coherence and specialisation: overview] + , cir_what :: InstanceWhat } | NotSure -- Multiple matches and/or one or more unifiers -data InstanceWhat -- How did we solve this constraint? - = BuiltinEqInstance -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2 - -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] - - | BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn) - -- See Note [Well-staged instance evidence] - - | BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is - -- KnownNat, .. etc (classes with no top-level evidence) - - | LocalInstance -- Solved by a quantified constraint - -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] - - | TopLevInstance -- Solved by a top-level instance decl - { iw_dfun_id :: DFunId - , iw_safe_over :: SafeOverlapping } - instance Outputable ClsInstResult where ppr NoInstance = text "NoInstance" ppr NotSure = text "NotSure" @@ -127,15 +107,6 @@ , cir_what = what }) = text "OneInst" <+> vcat [ppr ev, ppr what] -instance Outputable InstanceWhat where - ppr BuiltinInstance = text "a built-in instance" - ppr BuiltinTypeableInstance {} = text "a built-in typeable instance" - ppr BuiltinEqInstance = text "a built-in equality instance" - ppr LocalInstance = text "a locally-quantified instance" - ppr (TopLevInstance { iw_dfun_id = dfun }) - = hang (text "instance" <+> pprSigmaType (idType dfun)) - 2 (text "--" <+> pprDefinedAt (idName dfun)) - safeOverlap :: InstanceWhat -> Bool safeOverlap (TopLevInstance { iw_safe_over = so }) = so safeOverlap _ = True @@ -152,18 +123,19 @@ -> Bool -- True <=> caller is the short-cut solver -- See Note [Shortcut solving: overlap] -> Class -> [Type] -> TcM ClsInstResult +-- Precondition: Class does not satisfy GHC.Core.Predicate.isEqualityClass +-- (That is handled by a separate code path: see GHC.Tc.Solver.Dict.solveDict, +-- which calls solveEqualityDict for equality classes.) matchGlobalInst dflags short_cut clas tys - | cls_name == knownNatClassName = matchKnownNat dflags short_cut clas tys - | cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys - | cls_name == knownCharClassName = matchKnownChar dflags short_cut clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas tys - | cls_name == withDictClassName = matchWithDict tys - | clas `hasKey` heqTyConKey = matchHeteroEquality tys - | clas `hasKey` eqTyConKey = matchHomoEquality tys - | clas `hasKey` coercibleTyConKey = matchCoercible tys - | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys - | otherwise = matchInstEnv dflags short_cut clas tys + | cls_name == knownNatClassName = matchKnownNat dflags short_cut clas tys + | cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys + | cls_name == knownCharClassName = matchKnownChar dflags short_cut clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas tys + | cls_name == withDictClassName = matchWithDict tys + | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys + | cls_name == unsatisfiableClassName = return NoInstance -- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors + | otherwise = matchInstEnv dflags short_cut clas tys where cls_name = className clas @@ -188,12 +160,12 @@ ; case (matches, unify, safeHaskFail) of -- Nothing matches - ([], NoUnifiers, _) + ([], NoUnifiers{}, _) -> do { traceTc "matchClass not matching" (ppr pred $$ ppr (ie_local instEnvs)) ; return NoInstance } -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], NoUnifiers, False) + ([(ispec, inst_tys)], NoUnifiers canonical, False) | short_cut_solver -- Called from the short-cut solver , isOverlappable ispec -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT @@ -206,11 +178,11 @@ | otherwise -> do { let dfun_id = instanceDFunId ispec ; traceTc "matchClass success" $ - vcat [text "dict" <+> ppr pred, + vcat [text "dict" <+> ppr pred <+> parens (if canonical then text "canonical" else text "non-canonical"), text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ] -- Record that this dfun is needed - ; match_one (null unsafeOverlaps) dfun_id inst_tys } + ; match_one (null unsafeOverlaps) canonical dfun_id inst_tys } -- More than one matches (or Safe Haskell fail!). Defer any -- reactions of a multitude until we learn more about the reagent @@ -221,16 +193,17 @@ where pred = mkClassPred clas tys -match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult - -- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv -match_one so dfun_id mb_inst_tys +match_one :: SafeOverlapping -> Canonical -> DFunId -> [DFunInstType] + -> TcM ClsInstResult +match_one so canonical dfun_id mb_inst_tys = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys) ; (tys, theta) <- instDFunType dfun_id mb_inst_tys ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta) - ; return $ OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = TopLevInstance { iw_dfun_id = dfun_id - , iw_safe_over = so } } } + ; return $ OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_canonical = canonical + , cir_what = TopLevInstance { iw_dfun_id = dfun_id + , iw_safe_over = so } } } {- Note [Shortcut solving: overlap] @@ -262,9 +235,10 @@ matchCTuple :: Class -> [Type] -> TcM ClsInstResult matchCTuple clas tys -- (isCTupleClass clas) holds - = return (OneInst { cir_new_theta = tys - , cir_mk_ev = tuple_ev - , cir_what = BuiltinInstance }) + = return (OneInst { cir_new_theta = tys + , cir_mk_ev = tuple_ev + , cir_canonical = True + , cir_what = BuiltinInstance }) -- The dfun *is* the data constructor! where data_con = tyConSingleDataCon (classTyCon clas) @@ -295,9 +269,10 @@ instance KnownNat 2 where natSing = SNat 2 ... -In practice, we solve `KnownNat` predicates in the type-checker -(see GHC.Tc.Solver.Interact) because we can't have infinitely many instances. -The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. +In practice, we solve `KnownNat` predicates in the type-checker (see +`matchKnownNat` in this module) because we can't have infinitely many +instances. The evidence (aka "dictionary") for `KnownNat` is of the +form `EvLit (EvNum n)`. We make the following assumptions about dictionaries in GHC: 1. The "dictionary" for classes with a single method---like `KnownNat`---is @@ -424,9 +399,10 @@ , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] -- SNat n ~ Integer , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep)) - = return $ OneInst { cir_new_theta = [] - , cir_mk_ev = \_ -> ev_tm - , cir_what = BuiltinInstance } + = return $ OneInst { cir_new_theta = [] + , cir_mk_ev = \_ -> ev_tm + , cir_canonical = True + , cir_what = BuiltinInstance } | otherwise = pprPanic "makeLitDict" $ @@ -457,19 +433,9 @@ -- the WithDict dictionary: -- -- \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> - -- nospec @(cls => a) k (sv |> (sub co ; sym co2)) - -- - -- where nospec :: forall a. a -> a ensures that the typeclass specialiser - -- doesn't attempt to common up this evidence term with other evidence terms - -- of the same type. - -- - -- See (WD6) in Note [withDict], and Note [nospecId magic] in GHC.Types.Id.Make. + -- k (sv |> (sub co ; sym co2)) ; let evWithDict co2 = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ - Var nospecId - `App` - (Type $ mkInvisFunTy cls openAlphaTy) - `App` Var k `App` (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co)) @@ -482,9 +448,10 @@ [cls, mty] [evWithDict (evTermCoercion (EvExpr c))] mk_ev e = pprPanic "matchWithDict" (ppr e) - ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } + ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty] + , cir_mk_ev = mk_ev + , cir_canonical = False -- See (WD6) in Note [withDict] + , cir_what = BuiltinInstance } } matchWithDict _ @@ -587,12 +554,14 @@ (WD6) In fact, we desugar `withDict @cls @mty @{rr} @r` to \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> - nospec @(cls => a) k (sv |> (sub co2 ; sym co))) + k (sv |> (sub co2 ; sym co))) - That is, we cast the method using a coercion, and apply k to it. - However, we use the 'nospec' magicId (see Note [nospecId magic] in GHC.Types.Id.Make) - to ensure that the typeclass specialiser doesn't incorrectly common-up distinct - evidence terms. This is super important! Suppose we have calls + That is, we cast the method using a coercion, and apply k to + it. Moreover, we mark the evidence as non-canonical, resulting in + the use of the 'nospec' magicId (see Note [nospecId magic] in + GHC.Types.Id.Make) to ensure that the typeclass specialiser + doesn't incorrectly common-up distinct evidence terms. This is + super important! Suppose we have calls withDict A k withDict B k @@ -672,14 +641,15 @@ -- | Representation for a type @ty@ of the form @arg -> ret@. doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult doFunTy clas ty mult arg_ty ret_ty - = return $ OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } + = return $ OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , cir_canonical = True + , cir_what = BuiltinInstance } where preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty] mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $ EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) - mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy" + mk_ev _ = panic "GHC.Tc.Instance.Class.doFunTy" -- | Representation for type constructor applied to some kinds. @@ -688,9 +658,10 @@ doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args | tyConIsTypeable tc - = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args - , cir_mk_ev = mk_ev - , cir_what = BuiltinTypeableInstance tc } + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args + , cir_mk_ev = mk_ev + , cir_canonical = True + , cir_what = BuiltinTypeableInstance tc } | otherwise = return NoInstance where @@ -719,9 +690,10 @@ | isForAllTy (typeKind f) = return NoInstance -- We can't solve until we know the ctr. | otherwise - = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] + , cir_mk_ev = mk_ev + , cir_canonical = True + , cir_what = BuiltinInstance } where mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) mk_ev _ = panic "doTyApp" @@ -739,9 +711,10 @@ ; let kc_pred = mkClassPred kc_clas [ t ] mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) mk_ev _ = panic "doTyLit" - ; return (OneInst { cir_new_theta = [kc_pred] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance }) } + ; return (OneInst { cir_new_theta = [kc_pred] + , cir_mk_ev = mk_ev + , cir_canonical = True + , cir_what = BuiltinInstance }) } {- Note [Typeable (T a b c)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -827,31 +800,26 @@ ***********************************************************************-} -- See also Note [The equality types story] in GHC.Builtin.Types.Prim -matchHeteroEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~~ t2) -matchHeteroEquality args - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ] - , cir_mk_ev = evDataConApp heqDataCon args - , cir_what = BuiltinEqInstance }) +matchEqualityInst :: Class -> [Type] -> (DataCon, Role, Type, Type) +-- Precondition: `cls` satisfies GHC.Core.Predicate.isEqualityClass +-- See Note [Solving equality classes] in GHC.Tc.Solver.Dict +matchEqualityInst cls args + | cls `hasKey` eqTyConKey -- Solves (t1 ~ t2) + , [_,t1,t2] <- args + = (eqDataCon, Nominal, t1, t2) -matchHomoEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~ t2) -matchHomoEquality args@[k,t1,t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ] - , cir_mk_ev = evDataConApp eqDataCon args - , cir_what = BuiltinEqInstance }) -matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args) + | cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2) + , [_,_,t1,t2] <- args + = (heqDataCon, Nominal, t1, t2) --- See also Note [The equality types story] in GHC.Builtin.Types.Prim -matchCoercible :: [Type] -> TcM ClsInstResult -matchCoercible args@[k, t1, t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] - , cir_mk_ev = evDataConApp coercibleDataCon args - , cir_what = BuiltinEqInstance }) - where - args' = [k, k, t1, t2] -matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args) + | cls `hasKey` coercibleTyConKey -- Solves (Coercible t1 t2) + , [_, t1, t2] <- args + = (coercibleDataCon, Representational, t1, t2) + | otherwise -- Does not satisfy the precondition + = pprPanic "matchEqualityInst" (ppr (mkClassPred cls args)) + + {- ******************************************************************** * * Class lookup for overloaded record fields @@ -976,11 +944,12 @@ -- it must not be higher-rank. ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty then do { -- See Note [Unused name reporting and HasField] - addUsedGRE True gre - ; keepAlive (greMangledName gre) - ; return OneInst { cir_new_theta = theta - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } } + addUsedGRE AllDeprecationWarnings gre + ; keepAlive (greName gre) + ; return OneInst { cir_new_theta = theta + , cir_mk_ev = mk_ev + , cir_canonical = True + , cir_what = BuiltinInstance } } else matchInstEnv dflags short_cut clas tys } _ -> matchInstEnv dflags short_cut clas tys } 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 @@ -6,7 +6,6 @@ checkFamInstConsistency, tcExtendLocalFamInstEnv, tcLookupDataFamInst, tcLookupDataFamInst_maybe, tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, - newFamInst, -- * Injectivity reportInjectivityErrors, reportConflictingInjectivityErrs @@ -14,11 +13,10 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Core.FamInstEnv -import GHC.Core.InstEnv( roughMatchTcs ) import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -31,7 +29,6 @@ import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) import GHC.Tc.Utils.TcType import GHC.Unit.External @@ -161,44 +158,6 @@ {- ************************************************************************ * * - Making a FamInst -* * -************************************************************************ --} - --- All type variables in a FamInst must be fresh. This function --- creates the fresh variables and applies the necessary substitution --- It is defined here to avoid a dependency from FamInstEnv on the monad --- code. - -newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst --- Freshen the type variables of the FamInst branches -newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) - = do { - -- Freshen the type variables - (subst, tvs') <- freshenTyVarBndrs tvs - ; (subst, cvs') <- freshenCoVarBndrsX subst cvs - ; let lhs' = substTys subst lhs - rhs' = substTy subst rhs - - ; return (FamInst { fi_fam = tyConName fam_tc - , fi_flavor = flavor - , fi_tcs = roughMatchTcs lhs - , fi_tvs = tvs' - , fi_cvs = cvs' - , fi_tys = lhs' - , fi_rhs = rhs' - , fi_axiom = axiom }) } - where - CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomSingleBranch axiom - - -{- -************************************************************************ -* * Optimised overlap checking for family instances * * ************************************************************************ @@ -230,9 +189,6 @@ indirectly), we check that they are consistent now. (So that we can be certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.) -There is some fancy footwork regarding hs-boot module loops, see -Note [Don't check hs-boot type family instances too early] - Note [Checking family instance optimization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As explained in Note [Checking family instance consistency] @@ -286,9 +242,6 @@ This is basically the idea from #13092, comment:14. -} --- This function doesn't check ALL instances for consistency, --- only ones that aren't involved in recursive knot-tying --- loops; see Note [Don't check hs-boot type family instances too early]. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. @@ -391,68 +344,7 @@ sizeE2 = famInstEnvSize env2' (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') else (env2', env1') - -- Note [Don't check hs-boot type family instances too early] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Family instance consistency checking involves checking that - -- the family instances of our imported modules are consistent with - -- one another; this might lead you to think that this process - -- has nothing to do with the module we are about to typecheck. - -- Not so! Consider the following case: - -- - -- -- A.hs-boot - -- type family F a - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- type instance F Int = Bool - -- - -- -- A.hs - -- import B - -- type family F a - -- - -- When typechecking A, we are NOT allowed to poke the TyThing - -- for F until we have typechecked the family. Thus, we - -- can't do consistency checking for the instance in B - -- (checkFamInstConsistency is called during renaming). - -- Failing to defer the consistency check lead to #11062. - -- - -- Additionally, we should also defer consistency checking when - -- type from the hs-boot file of the current module occurs on - -- the left hand side, as we will poke its TyThing when checking - -- for overlap. - -- - -- -- F.hs - -- type family F a - -- - -- -- A.hs-boot - -- import F - -- data T - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- import F - -- type instance F T = Int - -- - -- -- A.hs - -- import B - -- data T = MkT - -- - -- In fact, it is even necessary to defer for occurrences in - -- the RHS, because we may test for *compatibility* in event - -- of an overlap. - -- - -- Why don't we defer ALL of the checks to later? Well, many - -- instances aren't involved in the recursive loop at all. So - -- we might as well check them immediately; and there isn't - -- a good time to check them later in any case: every time - -- we finish kind-checking a type declaration and add it to - -- a context, we *then* consistency check all of the instances - -- which mentioned that type. We DO want to check instances - -- as quickly as possible, so that we aren't typechecking - -- values with inconsistent axioms in scope. - -- - -- See also Note [Tying the knot] - -- for why we are doing this at all. + ; let check_now = famInstEnvElts env1 ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now 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 @@ -35,8 +35,9 @@ import GHC.Core.InstEnv import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Compare( eqTypes, eqType ) -import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) +import GHC.Tc.Errors.Types ( CoverageProblem(..), FailedCoverageCondition(..) ) +import GHC.Tc.Types.Constraint ( isUnsatisfiableCt_maybe ) import GHC.Tc.Utils.TcType( transSuperClasses ) import GHC.Types.Var.Set @@ -45,14 +46,13 @@ import GHC.Utils.Outputable import GHC.Utils.FV -import GHC.Utils.Error( Validity'(..), Validity, allValid ) +import GHC.Utils.Error( Validity'(..), allValid ) import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Data.Pair ( Pair(..) ) -import Data.List ( nubBy ) -import Data.Maybe -import Data.Foldable ( fold ) +import GHC.Data.Pair ( Pair(..) ) +import Data.List ( nubBy ) +import Data.Maybe ( isJust, isNothing ) {- ************************************************************************ @@ -392,7 +392,7 @@ checkInstCoverage :: Bool -- Be liberal -> Class -> [PredType] -> [Type] - -> Validity + -> Validity' CoverageProblem -- "be_liberal" flag says whether to use "liberal" coverage of -- See Note [Coverage condition] below -- @@ -401,12 +401,23 @@ -- Just msg => coverage problem described by msg checkInstCoverage be_liberal clas theta inst_taus + | any (isJust . isUnsatisfiableCt_maybe) theta + -- As per [GHC proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst), + -- we skip checking the coverage condition if there is an "Unsatisfiable" + -- constraint in the instance context. + -- + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (E). + = IsValid + | otherwise = allValid (map fundep_ok fds) where (tyvars, fds) = classTvsFds clas fundep_ok fd - | and (isEmptyVarSet <$> undetermined_tvs) = IsValid - | otherwise = NotValid msg + | all isEmptyVarSet undetermined_tvs + = IsValid + | otherwise + = NotValid not_covered_msg where (ls,rs) = instFD fd tyvars inst_taus ls_tvs = tyCoVarsOfTypes ls @@ -419,33 +430,18 @@ liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - undet_set = fold undetermined_tvs + not_covered_msg = + CoverageProblem + { not_covered_fundep = fd + , not_covered_fundep_inst = (ls, rs) + , not_covered_invis_vis_tvs = undetermined_tvs + , not_covered_liberal = + if be_liberal + then FailedLICC + else FailedICC + { alsoFailedLICC = not $ all isEmptyVarSet liberal_undet_tvs } + } - msg = pprWithExplicitKindsWhen - (isEmptyVarSet $ pSnd undetermined_tvs) $ - vcat [ -- text "ls_tvs" <+> ppr ls_tvs - -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) - -- , text "theta" <+> ppr theta - -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs)) - -- , text "rs_tvs" <+> ppr rs_tvs - sep [ text "The" - <+> ppWhen be_liberal (text "liberal") - <+> text "coverage condition fails in class" - <+> quotes (ppr clas) - , nest 2 $ text "for functional dependency:" - <+> quotes (pprFunDep fd) ] - , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls - , nest 2 $ - (if isSingleton ls - then text "does not" - else text "do not jointly") - <+> text "determine rhs type"<>plural rs - <+> pprQuotedList rs ] - , text "Un-determined variable" <> pluralVarSet undet_set <> colon - <+> pprVarSet undet_set (pprWithCommas ppr) - , ppWhen (not be_liberal && - and (isEmptyVarSet <$> liberal_undet_tvs)) $ - text "Using UndecidableInstances might help" ] {- Note [Closing over kinds in coverage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -35,7 +35,7 @@ import GHC.Core.DataCon import GHC.Unit.Module import GHC.Hs -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.Bag import GHC.Types.Var ( VarBndr(..) ) import GHC.Core.Map.Type @@ -94,7 +94,7 @@ interface file to find its type, value, etc 4. Solve Typeable constraints. This is done by a custom Typeable solver, - currently in GHC.Tc.Solver.Interact, that use M.$tcT so solve (Typeable T). + currently in GHC.Tc.Instance.Class, that use M.$tcT so solve (Typeable T). There are many wrinkles: 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 @@ -44,3004 +44,2920 @@ tcRnInstantiateSignature, loadUnqualIfaces, -- More private... - badReexportedBootThing, - checkBootDeclM, - missingBootThing, - getRenamedStuff, RenamedStuff - ) where - -import GHC.Prelude - -import GHC.Driver.Env -import GHC.Driver.Plugins -import GHC.Driver.Session -import GHC.Driver.Config.Diagnostic - -import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) -import GHC.Tc.Errors.Types -import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) -import GHC.Tc.Gen.HsType -import GHC.Tc.Validity( checkValidType ) -import GHC.Tc.Gen.Match -import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) -import GHC.Tc.Utils.Zonk -import GHC.Tc.Gen.Expr -import GHC.Tc.Gen.App( tcInferSigma ) -import GHC.Tc.Utils.Monad -import GHC.Tc.Gen.Export -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Instance.Family -import GHC.Tc.Gen.Annotation -import GHC.Tc.Gen.Bind -import GHC.Tc.Gen.Default -import GHC.Tc.Utils.Env -import GHC.Tc.Gen.Rule -import GHC.Tc.Gen.Foreign -import GHC.Tc.TyCl.Instance -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate (tcGetInsts) -import GHC.Tc.Solver -import GHC.Tc.TyCl -import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) -import GHC.Tc.Utils.Backpack - -import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import GHC.Rename.HsType -import GHC.Rename.Expr -import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Module -import GHC.Rename.Doc - -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) -import GHC.Iface.Env ( externaliseName ) -import GHC.Iface.Make ( coAxiomToIfaceDecl ) -import GHC.Iface.Load - -import GHC.Builtin.Types ( unitTy, mkListTy ) -import GHC.Builtin.Names -import GHC.Builtin.Utils - -import GHC.Hs -import GHC.Hs.Dump - -import GHC.Core.PatSyn ( pprPatSynType ) -import GHC.Core.Predicate ( classMethodTy ) -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.Class -import GHC.Core.Coercion.Axiom -import GHC.Core.Reduction ( Reduction(..) ) -import GHC.Core.RoughMap( RoughMatchTc(..) ) -import GHC.Core.TyCo.Ppr( debugPprType ) -import GHC.Core.FamInstEnv - ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) - -import GHC.Parser.Header ( mkPrelImports ) - -import GHC.IfaceToCore - -import GHC.Runtime.Context - -import GHC.Utils.Error -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc -import GHC.Utils.Logger - -import GHC.Types.Error -import GHC.Types.Name.Reader -import GHC.Types.Fixity.Env -import GHC.Types.Id as Id -import GHC.Types.Id.Info( IdDetails(..) ) -import GHC.Types.Var.Env -import GHC.Types.TypeEnv -import GHC.Types.Unique.FM -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Types.Annotations -import GHC.Types.SrcLoc -import GHC.Types.SourceFile -import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) -import GHC.Types.PkgQual -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Unit.External -import GHC.Unit.Types -import GHC.Unit.State -import GHC.Unit.Home -import GHC.Unit.Module -import GHC.Unit.Module.Warnings -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.Deps - -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Data.List.SetOps -import GHC.Data.Bag -import qualified GHC.Data.BooleanFormula as BF - -import Data.Functor.Classes ( liftEq ) -import Data.List ( sortBy, sort ) -import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.List.NonEmpty as NE -import Data.Ord -import Data.Data ( Data ) -import qualified Data.Set as S -import Control.DeepSeq -import Control.Monad - -{- -************************************************************************ -* * - Typecheck and rename a module -* * -************************************************************************ --} - --- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> ModSummary - -> Bool -- True <=> save renamed syntax - -> HsParsedModule - -> IO (Messages TcRnMessage, Maybe TcGblEnv) - -tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= L loc this_module} - | RealSrcSpan real_loc _ <- loc - = withTiming logger - (text "Renamer/typechecker"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ - withDefaultingPlugins hsc_env $ - withHoleFitPlugins hsc_env $ - - tcRnModuleTcRnM hsc_env mod_sum parsedModule pair - - | otherwise - = return (err_msg `addMessage` emptyMessages, Nothing) - - where - hsc_src = ms_hsc_src mod_sum - logger = hsc_logger hsc_env - home_unit = hsc_home_unit hsc_env - err_msg = mkPlainErrorMsgEnvelope loc $ - TcRnModMissingRealSrcSpan this_mod - - pair :: (Module, SrcSpan) - pair@(this_mod,_) - | Just (L mod_loc mod) <- hsmodName this_module - = (mkHomeModule home_unit mod, locA mod_loc) - - | otherwise -- 'module M where' is omitted - = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) - - - - -tcRnModuleTcRnM :: HscEnv - -> ModSummary - -> HsParsedModule - -> (Module, SrcSpan) - -> TcRn TcGblEnv --- Factored out separately from tcRnModule so that a Core plugin can --- call the type checker directly -tcRnModuleTcRnM hsc_env mod_sum - (HsParsedModule { - hpm_module = - (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr) - maybe_mod export_ies import_decls local_decls)), - hpm_src_files = src_files - }) - (this_mod, prel_imp_loc) - = setSrcSpan loc $ - do { let { explicit_mod_hdr = isJust maybe_mod - ; hsc_src = ms_hsc_src mod_sum } - ; -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - tcg_env <- getGblEnv - ; boot_info <- tcHiBootIface hsc_src this_mod - ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) - $ do - { -- Deal with imports; first add implicit prelude - implicit_prelude <- xoptM LangExt.ImplicitPrelude - ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude import_decls } - - ; when (notNull prel_imports) $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) - addDiagnostic msg - - ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (L _ idecl) = - ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) - , reLoc $ ideclName idecl) - } - ; raw_sig_imports <- liftIO - $ findExtraSigImports hsc_env hsc_src - (moduleName this_mod) - ; raw_req_imports <- liftIO - $ implicitRequirements hsc_env - (map simplifyImport (prel_imports - ++ import_decls)) - ; let { mkImport mod_name = noLocA - $ (simpleImportDecl mod_name) - { ideclImportList = Just (Exactly, noLocA [])}} - ; let { withReason t imps = map (,text t) imps } - ; let { all_imports = withReason "is implicitly imported" prel_imports - ++ withReason "is directly imported" import_decls - ++ withReason "is an extra sig import" (map mkImport raw_sig_imports) - ++ withReason "is an implicit req import" (map mkImport raw_req_imports) } - ; -- OK now finally rename the imports - tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env all_imports - - -- Put a version of the header without identifier info into the tcg_env - -- Make sure to do this before 'tcRnSrcDecls', because we need the - -- module header when we're splicing TH, since it can be accessed via - -- 'getDoc'. - -- We will rename it properly after renaming everything else so that - -- haddock can link the identifiers - ; tcg_env <- return (tcg_env - { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) - <$> maybe_doc_hdr }) - ; -- If the whole module is warned about or deprecated - -- (via mod_deprec) record that in tcg_warns. If we do thereby add - -- a WarnAll, it will override any subsequent deprecations added to tcg_warns - ; tcg_env1 <- case mod_deprec of - Just (L _ txt) -> do { txt' <- rnWarningTxt txt - ; pure $ tcg_env {tcg_warns = WarnAll txt'} - } - Nothing -> pure tcg_env - ; setGblEnv tcg_env1 - $ do { -- Rename and type check the declarations - traceRn "rn1a" empty - ; tcg_env <- if isHsBootOrSig hsc_src - then do { - ; tcg_env <- tcRnHsBootDecls hsc_src local_decls - ; traceRn "rn4a: before exports" empty - ; tcg_env <- setGblEnv tcg_env $ - rnExports explicit_mod_hdr export_ies - ; traceRn "rn4b: after exports" empty - ; return tcg_env - } - else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr export_ies local_decls - - ; whenM (goptM Opt_DoCoreLinting) $ - lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env - - ; setGblEnv tcg_env - $ do { -- Compare hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_info - ; -- The new type env is already available to stuff - -- slurped from interface files, via - -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this - -- includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for - -- boot_dfuns, which may be mentioned in imported - -- unfoldings. - ; -- Report unused names - -- Do this /after/ typeinference, so that when reporting - -- a function with no type signature we can give the - -- inferred type - ; reportUnusedNames tcg_env hsc_src - - -- Rename the module header properly after we have renamed everything else - ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr; - ; tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - - ; -- add extra source files to tcg_dependent_files - addDependentFiles src_files - -- Ensure plugins run with the same tcg_env that we pass in - ; setGblEnv tcg_env - $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env - ; -- Dump output and return - tcDump tcg_env - ; return tcg_env - } - } - } - } - } - -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = text "Module `Prelude' implicitly imported" - -{- -************************************************************************ -* * - Import declarations -* * -************************************************************************ --} - -tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv -tcRnImports hsc_env import_decls - = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; - - ; this_mod <- getModule - ; gbl_env <- getGblEnv - ; let { -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file. This - -- filtering also ensures that we don't see instances from - -- modules batch (@--make@) compiled before this one, but - -- which are not below this one. - ; (home_insts, home_fam_insts) = - - hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env))) - - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { - updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports } - } - - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { - tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = rn_imports, - tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module (including orphan family - -- instance-module) interfaces, so that their rules and - -- instance decls will be found. But filter out a - -- self hs-boot: these instances will be checked when - -- we define them locally. - -- (We don't need to load non-orphan family instance - -- modules until we either try to use the instances they - -- define, or define our own family instances, at which - -- point we need to check them for consistency.) - ; loadModuleInterfaces (text "Loading orphan modules") - (filter (/= this_mod) (imp_orphs imports)) - - -- Check type-family consistency between imports. - -- See Note [The type family instance consistency story] - ; traceRn "rn1: checking family instance consistency {" empty - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; checkFamInstConsistency dir_imp_mods - ; traceRn "rn1: } checking family instance consistency" empty - - ; getGblEnv } } - -{- -************************************************************************ -* * - Type-checking the top level of a module -* * -************************************************************************ --} - -tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [LIE GhcPs]) - -> [LHsDecl GhcPs] -- Declarations - -> TcM TcGblEnv -tcRnSrcDecls explicit_mod_hdr export_ies decls - = do { -- Do all the declarations - ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls - - ------ Simplify constraints --------- - -- - -- We do this after checkMainType, so that we use the type - -- info that checkMainType adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop, - -- and affects how names are rendered in error messages - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - restoreEnvs (tcg_env, tcl_env) $ - do { lie_main <- checkMainType tcg_env - ; simplifyTop (lie `andWC` lie_main) } - - -- Emit Typeable bindings - ; tcg_env <- setGblEnv tcg_env $ - mkTypeableBinds - - ; traceTc "Tc9" empty - ; failIfErrsM -- Stop now if if there have been errors - -- Continuing is a waste of time; and we may get debug - -- warnings when zonking about strangely-typed TyCons! - - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. - -- This pass also warns about missing type signatures - ; (id_env, ev_binds', binds', fords', imp_specs', rules') - <- zonkTcGblEnv new_ev_binds tcg_env - - --------- Run finalizers -------------- - -- Finalizers must run after constraints are simplified, lest types - -- might not be complete when using reify (see #12777). - -- and also after we zonk the first time because we run typed splices - -- in the zonker which gives rise to the finalisers. - ; let -- init_tcg_env: - -- * Remove accumulated bindings, rules and so on from - -- TcGblEnv. They are now in ev_binds', binds', etc. - -- * Add the zonked Ids from the value bindings to tcg_type_env - -- Up to now these Ids are only in tcl_env's type-envt - init_tcg_env = tcg_env { tcg_binds = emptyBag - , tcg_ev_binds = emptyBag - , tcg_imp_specs = [] - , tcg_rules = [] - , tcg_fords = [] - , tcg_type_env = tcg_type_env tcg_env - `plusTypeEnv` id_env } - ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env - run_th_modfinalizers - ; finishTH - ; traceTc "Tc11" empty - - --------- Deal with the exports ---------- - -- Can't be done earlier, because the export list must "see" - -- the declarations created by the finalizers - ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ - rnExports explicit_mod_hdr export_ies - - --------- Emit the ':Main.main = runMainIO main' declaration ---------- - -- Do this /after/ rnExports, so that it can consult - -- the tcg_exports created by rnExports - ; (tcg_env, main_ev_binds) - <- restoreEnvs (tcg_env, tcl_env) $ - do { (tcg_env, lie) <- captureTopConstraints $ - checkMain explicit_mod_hdr export_ies - ; ev_binds <- simplifyTop lie - ; return (tcg_env, ev_binds) } - - ; failIfErrsM -- Stop now if if there have been errors - -- Continuing is a waste of time; and we may get debug - -- warnings when zonking about strangely-typed TyCons! - - ---------- Final zonking --------------- - -- Zonk the new bindings arising from running the finalisers, - -- and main. This won't give rise to any more finalisers as you - -- can't nest finalisers inside finalisers. - ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) - <- zonkTcGblEnv main_ev_binds tcg_env - - ; let { !final_type_env = tcg_type_env tcg_env - `plusTypeEnv` id_env_mf - -- Add the zonked Ids from the value bindings (they were in tcl_env) - -- Force !final_type_env, lest we retain an old reference - -- to the previous tcg_env - - ; tcg_env' = tcg_env - { tcg_binds = binds' `unionBags` binds_mf - , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf - , tcg_imp_specs = imp_specs' ++ imp_specs_mf - , tcg_rules = rules' ++ rules_mf - , tcg_fords = fords' ++ fords_mf } } ; - - ; setGlobalTypeEnv tcg_env' final_type_env - } - -zonkTcGblEnv :: Bag EvBind -> TcGblEnv - -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, - [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) -zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds - , tcg_ev_binds = cur_ev_binds - , tcg_imp_specs = imp_specs - , tcg_rules = rules - , tcg_fords = fords }) - = {-# SCC "zonkTopDecls" #-} - setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering - -- error messages during zonking (notably levity errors) - do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds - ; zonkTopDecls all_ev_binds binds rules imp_specs fords } - --- | Runs TH finalizers and renames and typechecks the top-level declarations --- that they could introduce. -run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) -run_th_modfinalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - th_modfinalizers <- readTcRef th_modfinalizers_var - if null th_modfinalizers - then getEnvs - else do - writeTcRef th_modfinalizers_var [] - let run_finalizer (lcl_env, f) = - restoreLclEnv lcl_env (runRemoteModFinalizers f) - - (_, lie_th) <- captureTopConstraints $ - mapM_ run_finalizer th_modfinalizers - - -- Finalizers can add top-level declarations with addTopDecls, so - -- we have to run tc_rn_src_decls to get them - (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] - - restoreEnvs (tcg_env, tcl_env) $ do - -- Subsequent rounds of finalizers run after any new constraints are - -- simplified, or some types might not be complete when using reify - -- (see #12777). - new_ev_binds <- {-# SCC "simplifyTop2" #-} - simplifyTop (lie_th `andWC` lie_top_decls) - addTopEvBinds new_ev_binds run_th_modfinalizers - -- addTopDecls can add declarations which add new finalizers. - -tc_rn_src_decls :: [LHsDecl GhcPs] - -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) --- Loops around dealing with each top level inter-splice group --- in turn, until it's dealt with the entire module --- Never emits constraints; calls captureTopConstraints internally -tc_rn_src_decls ds - = {-# SCC "tc_rn_src_decls" #-} - do { (first_group, group_tail) <- findSplice ds - -- If ds is [] we get ([], Nothing) - - -- Deal with decls up to, but not including, the first splice - ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group - -- rnTopSrcDecls fails if there are any errors - - -- Get TH-generated top-level declarations and make sure they don't - -- contain any splices since we don't handle that at the moment - -- - -- The plumbing here is a bit odd: see #10853 - ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - ; th_ds <- readTcRef th_topdecls_var - ; writeTcRef th_topdecls_var [] - - ; (tcg_env, rn_decls) <- - if null th_ds - then return (tcg_env, rn_decls) - else do { (th_group, th_group_tail) <- findSplice th_ds - ; case th_group_tail of - { Nothing -> return () - ; Just (SpliceDecl _ (L loc _) _, _) -> - setSrcSpanA loc - $ addErr (mkTcRnUnknownMessage $ mkPlainError noHints $ text - ("Declaration splices are not " - ++ "permitted inside top-level " - ++ "declarations added with addTopDecls")) - } - -- Rename TH-generated top-level declarations - ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env - $ rnTopSrcDecls th_group - - -- Dump generated top-level declarations - ; let msg = "top-level declarations added with addTopDecls" - ; traceSplice - $ SpliceInfo { spliceDescription = msg - , spliceIsDecl = True - , spliceSource = Nothing - , spliceGenerated = ppr th_rn_decls } - ; return (tcg_env, appendGroups rn_decls th_rn_decls) - } - - -- Type check all declarations - -- NB: set the env **before** captureTopConstraints so that error messages - -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that - -- the captureTopConstraints must go here, not in tcRnSrcDecls. - ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ - captureTopConstraints $ - tcTopSrcDecls rn_decls - - -- If there is no splice, we're nearly done - ; restoreEnvs (tcg_env, tcl_env) $ - case group_tail of - { Nothing -> return (tcg_env, tcl_env, lie1) - - -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> - do { - -- We need to simplify any constraints from the previous declaration - -- group, or else we might reify metavariables, as in #16980. - ; ev_binds1 <- simplifyTop lie1 - - -- Rename the splice expression, and get its supporting decls - ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice - - -- Glue them on the front of the remaining decls and loop - ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - addTopEvBinds ev_binds1 $ - tc_rn_src_decls (spliced_decls ++ rest_ds) - } - } - } - -{- -************************************************************************ -* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -* * -************************************************************************ --} - -tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv -tcRnHsBootDecls hsc_src decls - = do { (first_group, group_tail) <- findSplice decls - - -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_annds = _ - , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) - <- rnTopSrcDecls first_group - - -- The empty list is for extra dependencies coming from .hs-boot files - -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Module - - ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { - -- NB: setGblEnv **before** captureTopConstraints so that - -- if the latter reports errors, it knows what's in scope - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d - Nothing -> return () - ; mapM_ (badBootDecl hsc_src "foreign") for_decls - ; mapM_ (badBootDecl hsc_src "default") def_decls - ; mapM_ (badBootDecl hsc_src "rule") rule_decls - - -- Typecheck type/class/instance decls - ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds - ; setGblEnv tcg_env $ do { - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds val_sigs - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 - }}} - ; traceTc "boot" (ppr lie); return gbl_env } - -badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () -badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (char 'A' <+> text what - <+> text "declaration is not (currently) allowed in a" - <+> (case hsc_src of - HsBootFile -> text "hs-boot" - HsigFile -> text "hsig" - _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> text "file") - -{- -Once we've typechecked the body of the module, we want to compare what -we've found (gathered in a TypeEnv) with the hi-boot details (if any). --} - -checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv --- Compare the hi-boot file for this module (if there is one) --- with the type environment we've just come up with --- In the common case where there is no hi-boot file, the list --- of boot_names is empty. - -checkHiBootIface tcg_env boot_info - | NoSelfBoot <- boot_info -- Common case - = return tcg_env - - | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! - = return tcg_env - - | SelfBoot { sb_mds = boot_details } <- boot_info - , TcGblEnv { tcg_binds = binds - , tcg_insts = local_insts - , tcg_type_env = local_type_env - , tcg_exports = local_exports } <- tcg_env - = do { -- This code is tricky, see Note [DFun knot-tying] - ; dfun_prs <- checkHiBootIface' local_insts local_type_env - local_exports boot_details - - -- Now add the boot-dfun bindings $fxblah = $fblah - -- to (a) the type envt, and (b) the top-level bindings - ; let boot_dfuns = map fst dfun_prs - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - tcg_env_w_binds - = tcg_env { tcg_binds = binds `unionBags` dfun_binds } - - ; type_env' `seq` - -- Why the seq? Without, we will put a TypeEnv thunk in - -- tcg_type_env_var. That thunk will eventually get - -- forced if we are typechecking interfaces, but that - -- is no good if we are trying to typecheck the very - -- DFun we were going to put in. - -- TODO: Maybe setGlobalTypeEnv should be strict. - setGlobalTypeEnv tcg_env_w_binds type_env' } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "checkHiBootIface: unreachable code" -#endif - -{- Note [DFun impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We return a list of "impedance-matching" bindings for the dfuns -defined in the hs-boot file, such as - $fxEqT = $fEqT -We need these because the module and hi-boot file might differ in -the name it chose for the dfun: the name of a dfun is not -uniquely determined by its type; there might be multiple dfuns -which, individually, would map to the same name (in which case -we have to disambiguate them.) There's no way for the hi file -to know exactly what disambiguation to use... without looking -at the hi-boot file itself. - -In fact, the names will always differ because we always pick names -prefixed with "$fx" for boot dfuns, and "$f" for real dfuns -(so that this impedance matching is always possible). - -Note [DFun knot-tying] -~~~~~~~~~~~~~~~~~~~~~~ -The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from -typechecking the hi-boot file that we are presently implementing. -Suppose we are typechecking the module A: when we typecheck the -hi-boot file, whenever we see an identifier A.T, we knot-tie this -identifier to the *local* type environment (via if_rec_types.) The -contract then is that we don't *look* at 'SelfBootInfo' until we've -finished typechecking the module and updated the type environment with -the new tycons and ids. - -This most works well, but there is one problem: DFuns! We do not want -to look at the mb_insts of the ModDetails in SelfBootInfo, because a -dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a -(lazily evaluated) lookup in the if_rec_types. We could extend the -type env, do a setGloblaTypeEnv etc; but that all seems very indirect. -It is much more directly simply to extract the DFunIds from the -md_types of the SelfBootInfo. - -See #4003, #16038 for why we need to take care here. --} - -checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] - -> ModDetails -> TcM [(Id, Id)] --- Variant which doesn't require a full TcGblEnv; you could get the --- local components from another ModDetails. -checkHiBootIface' - local_insts local_type_env local_exports - (ModDetails { md_types = boot_type_env - , md_fam_insts = boot_fam_insts - , md_exports = boot_exports }) - = do { traceTc "checkHiBootIface" $ vcat - [ ppr boot_type_env, ppr boot_exports] - - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports - - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") - -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... - - -- Check instance declarations - -- and generate an impedance-matching binding - ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns - - ; failIfErrsM - - ; return (catMaybes mb_dfun_prs) } - - where - boot_dfun_names = map idName boot_dfuns - boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env - -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts - -- We don't want to look at md_insts! - -- Why not? See Note [DFun knot-tying] - - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` boot_dfun_names = return () - - -- Check that the actual module exports the same thing - | missing_name:_ <- missing_names - = addErrAt (nameSrcSpan missing_name) - (missingBootThing True missing_name "exported by") - - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) - | isNothing mb_boot_thing = return () - - -- Check that the actual module also defines the thing, and - -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name, - Just boot_thing <- mb_boot_thing - = checkBootDeclM True boot_thing real_thing - - | otherwise - = addErrTc (missingBootThing True name "defined in") - where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - - local_export_env :: NameEnv AvailInfo - local_export_env = availsToNameEnv local_exports - - check_cls_inst :: DFunId -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent - -- real dfun. Delicate (like checkBootDecl) because it depends - -- on the types lining up precisely even to the ordering of - -- the type variables in the foralls. - check_cls_inst boot_dfun - | (real_dfun : _) <- find_real_dfun boot_dfun - , let local_boot_dfun = Id.mkExportedVanillaId - (idName boot_dfun) (idType real_dfun) - = return (Just (local_boot_dfun, real_dfun)) - -- Two tricky points here: - -- - -- * The local_boot_fun should have a Name from the /boot-file/, - -- but type from the dfun defined in /this module/. - -- That ensures that the TyCon etc inside the type are - -- the ones defined in this module, not the ones gotten - -- from the hi-boot file, which may have a lot less info - -- (#8743, comment:10). - -- - -- * The DFunIds from boot_details are /GlobalIds/, because - -- they come from typechecking M.hi-boot. - -- But all bindings in this module should be for /LocalIds/, - -- otherwise dependency analysis fails (#16038). This - -- is another reason for using mkExportedVanillaId, rather - -- that modifying boot_dfun, to make local_boot_fun. - - | otherwise - = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ - do { traceTc "check_cls_inst" $ vcat - [ text "local_insts" <+> - vcat (map (ppr . idType . instanceDFunId) local_insts) - , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] - - ; addErrTc (instMisMatch boot_dfun) - ; return Nothing } - - find_real_dfun :: DFunId -> [DFunId] - find_real_dfun boot_dfun - = [dfun | inst <- local_insts - , let dfun = instanceDFunId inst - , idType dfun `eqType` boot_dfun_ty ] - where - boot_dfun_ty = idType boot_dfun - - --- In general, to perform these checks we have to --- compare the TyThing from the .hi-boot file to the TyThing --- in the current source file. We must be careful to allow alpha-renaming --- where appropriate, and also the boot declaration is allowed to omit --- constructors and class methods. --- --- See rnfail055 for a good test of this stuff. - --- | Compares two things for equivalence between boot-file and normal code, --- reporting an error if they don't match up. -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt span - (bootMisMatch is_boot err real_thing boot_thing) - where - -- Here we use the span of the boot thing or, if it doesn't have a sensible - -- span, that of the real thing, - span - | let span = nameSrcSpan (getName boot_thing) - , isGoodSrcSpan span - = span - | otherwise - = nameSrcSpan (getName real_thing) - --- | Compares the two things for equivalence between boot-file and normal --- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ --- failure. If the difference will be apparent to the user, @Just empty@ is --- perfectly suitable. -checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc - -checkBootDecl _ (AnId id1) (AnId id2) - = assert (id1 == id2) $ - check (idType id1 `eqType` idType id2) - (text "The two types are different") - -checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon is_boot tc1 tc2 - -checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ _ = Just empty -- probably shouldn't happen - --- | Combines two potential error messages -andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc -Nothing `andThenCheck` msg = msg -msg `andThenCheck` Nothing = msg -Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) -infixr 0 `andThenCheck` - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, return the provided check -checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc -checkUnless True _ = Nothing -checkUnless False k = k - --- | Run the check provided for every pair of elements in the lists. --- The provided SDoc should name the element type, in the plural. -checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc - -> Maybe SDoc -checkListBy check_fun as bs whats = go [] as bs - where - herald = text "The" <+> whats <+> text "do not match" - - go [] [] [] = Nothing - go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) - go docs (x:xs) (y:ys) = case check_fun x y of - Just doc -> go (doc:docs) xs ys - Nothing -> go docs xs ys - go _ _ _ = Just (hang (herald <> colon) - 2 (text "There are different numbers of" <+> whats)) - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, fail with the given SDoc. -check :: Bool -> SDoc -> Maybe SDoc -check True _ = Nothing -check False doc = Just doc - --- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. -checkSuccess :: Maybe SDoc -checkSuccess = Nothing - ----------------- -checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc -checkBootTyCon is_boot tc1 tc2 - | not (eqType (tyConKind tc1) (tyConKind tc2)) - = Just $ text "The types have different kinds" -- First off, check the kind - - | Just c1 <- tyConClass_maybe tc1 - , Just c2 <- tyConClass_maybe tc2 - , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) - = classExtraBigSig c1 - (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) - = classExtraBigSig c2 - , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 - = let - eqSig (id1, def_meth1) (id2, def_meth2) - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "are different") `andThenCheck` - check (eqTypeX env op_ty1 op_ty2) - (text "The types of" <+> pname1 <+> - text "are different") `andThenCheck` - if is_boot - then check (liftEq eqDM def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are different") - else check (subDM op_ty1 def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are not compatible") - where - name1 = idName id1 - name2 = idName id2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - op_ty1 = classMethodTy id1 - op_ty2 = classMethodTy id2 - - eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon is_boot tc1 tc2 `andThenCheck` - check (eqATDef def_ats1 def_ats2) - (text "The associated type defaults differ") - - eqDM (_, VanillaDM) (_, VanillaDM) = True - eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 - eqDM _ _ = False - - -- NB: first argument is from hsig, second is from real impl. - -- Order of pattern matching matters. - subDM _ Nothing _ = True - subDM _ _ Nothing = False - - -- If the hsig wrote: - -- - -- f :: a -> a - -- default f :: a -> a - -- - -- this should be validly implementable using an old-fashioned - -- vanilla default method. - subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) - = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come - -- from tc1, so use eqType, and /not/ eqTypeX - - -- This case can occur when merging signatures - subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True - subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - -- Ignore the location of the defaults - eqATDef Nothing Nothing = True - eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 - eqATDef _ _ = False - - eqFD (as1,bs1) (as2,bs2) = - liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (liftEq eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (liftEq (eqTypeX env) sc_theta1 sc_theta2) - (text "The class constraints do not match") `andThenCheck` - checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` - checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` - check (classMinimalDef c1 `BF.implies` classMinimalDef c2) - (text "The MINIMAL pragmas are not compatible") - - | Just syn_rhs1 <- synTyConRhs_maybe tc1 - , Just syn_rhs2 <- synTyConRhs_maybe tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = assert (tc1 == tc2) $ - checkRoles roles1 roles2 `andThenCheck` - check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say - -- This allows abstract 'data T a' to be implemented using 'type T = ...' - -- and abstract 'class K a' to be implement using 'type K = ...' - -- See Note [Synonyms implement abstract data] - | not is_boot -- don't support for hs-boot yet - , isAbstractTyCon tc1 - , Just (tvs, ty) <- synTyConDefn_maybe tc2 - , Just (tc2', args) <- tcSplitTyConApp_maybe ty - = checkSynAbsData tvs ty tc2' args - -- TODO: When it's a synonym implementing a class, we really - -- should check if the fundeps are satisfied, but - -- there is not an obvious way to do this for a constraint synonym. - -- So for now, let it all through (it won't cause segfaults, anyway). - -- Tracked at #12704. - - -- This allows abstract 'data T :: Nat' to be implemented using - -- 'type T = 42' Since the kinds already match (we have checked this - -- upfront) all we need to check is that the implementation 'type T - -- = ...' defined an actual literal. See #15138 for the case this - -- handles. - | not is_boot - , isAbstractTyCon tc1 - , Just (_,ty2) <- synTyConDefn_maybe tc2 - , isJust (isLitTy ty2) - = Nothing - - | Just fam_flav1 <- famTyConFlav_maybe tc1 - , Just fam_flav2 <- famTyConFlav_maybe tc2 - = assert (tc1 == tc2) $ - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True - eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True - -- This case only happens for hsig merging: - eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True - eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True - eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True - eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 - eqFamFlav _ _ = False - injInfo1 = tyConInjectivityInfo tc1 - injInfo2 = tyConInjectivityInfo tc2 - in - -- check equality of roles, family flavours and injectivity annotations - -- (NB: Type family roles are always nominal. But the check is - -- harmless enough.) - checkRoles roles1 roles2 `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) - (whenPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match") `andThenCheck` - check (injInfo1 == injInfo2) (text "Injectivities do not match") - - | isAlgTyCon tc1 && isAlgTyCon tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = assert (tc1 == tc2) $ - checkRoles roles1 roles2 `andThenCheck` - check (liftEq (eqTypeX env) - (tyConStupidTheta tc1) (tyConStupidTheta tc2)) - (text "The datatype contexts do not match") `andThenCheck` - eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - - | otherwise = Just empty -- two very different types -- should be obvious - where - roles1 = tyConRoles tc1 -- the abstract one - roles2 = tyConRoles tc2 - roles_msg = text "The roles do not match." $$ - (text "Roles on abstract types default to" <+> - quotes (text "representational") <+> text "in boot files.") - - roles_subtype_msg = text "The roles are not compatible:" $$ - text "Main module:" <+> ppr roles2 $$ - text "Hsig file:" <+> ppr roles1 - - checkRoles r1 r2 - | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] - = check (r1 == r2) roles_msg - | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg - - -- Note [Role subtyping] - -- ~~~~~~~~~~~~~~~~~~~~~ - -- In the current formulation of roles, role subtyping is only OK if the - -- "abstract" TyCon was not representationally injective. Among the most - -- notable examples of non representationally injective TyCons are abstract - -- data, which can be implemented via newtypes (which are not - -- representationally injective). The key example is - -- in this example from #13140: - -- - -- -- In an hsig file - -- data T a -- abstract! - -- type role T nominal - -- - -- -- Elsewhere - -- foo :: Coercible (T a) (T b) => a -> b - -- foo x = x - -- - -- We must NOT allow foo to typecheck, because if we instantiate - -- T with a concrete data type with a phantom role would cause - -- Coercible (T a) (T b) to be provable. Fortunately, if T is not - -- representationally injective, we cannot make the inference that a ~N b if - -- T a ~R T b. - -- - -- Unconditional role subtyping would be possible if we setup - -- an extra set of roles saying when we can project out coercions - -- (we call these proj-roles); then it would NOT be valid to instantiate T - -- with a data type at phantom since the proj-role subtyping check - -- would fail. See #13140 for more details. - -- - -- One consequence of this is we get no role subtyping for non-abstract - -- data types in signatures. Suppose you have: - -- - -- signature A where - -- type role T nominal - -- data T a = MkT - -- - -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkSelCo). But if we can - -- subsequently replace T with one at phantom role, we would then be able to - -- infer things like T Int ~R T Bool which is bad news. - -- - -- We could allow role subtyping here if we didn't treat *any* data types - -- defined in signatures as injective. But this would be a bit surprising, - -- replacing a data type in a module with one in a signature could cause - -- your code to stop typechecking (whereas if you made the type abstract, - -- it is more understandable that the type checker knows less). - -- - -- It would have been best if this was purely a question of defaults - -- (i.e., a user could explicitly ask for one behavior or another) but - -- the current role system isn't expressive enough to do this. - -- Having explicit proj-roles would solve this problem. - - rolesSubtypeOf [] [] = True - -- NB: this relation is the OPPOSITE of the subroling relation - rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys - rolesSubtypeOf _ _ = False - - -- Note [Synonyms implement abstract data] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- An abstract data type or class can be implemented using a type synonym, - -- but ONLY if the type synonym is nullary and has no type family - -- applications. This arises from two properties of skolem abstract data: - -- - -- For any T (with some number of parameters), - -- - -- 1. T is a valid type (it is "curryable"), and - -- - -- 2. T is valid in an instance head (no type families). - -- - -- See also 'HowAbstract' and Note [Skolem abstract data]. - - -- Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, - -- check that this synonym is an acceptable implementation of @tc1@. - -- See Note [Synonyms implement abstract data] - checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc - checkSynAbsData tvs ty tc2' args = - check (null (tcTyFamInsts ty)) - (text "Illegal type family application in implementation of abstract data.") - `andThenCheck` - check (null tvs) - (text "Illegal parameterized type synonym in implementation of abstract data." $$ - text "(Try eta reducing your type synonym so that it is nullary.)") - `andThenCheck` - -- Don't report roles errors unless the type synonym is nullary - checkUnless (not (null tvs)) $ - assert (null roles2) $ - -- If we have something like: - -- - -- signature H where - -- data T a - -- module H where - -- data K a b = ... - -- type T = K Int - -- - -- we need to drop the first role of K when comparing! - checkRoles roles1 (drop (length args) (tyConRoles tc2')) -{- - -- Hypothetically, if we were allow to non-nullary type synonyms, here - -- is how you would check the roles - if length tvs == length roles1 - then checkRoles roles1 roles2 - else case tcSplitTyConApp_maybe ty of - Just (tc2', args) -> - checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) - Nothing -> Just roles_msg --} - - eqAlgRhs _ (AbstractTyCon {}) _rhs2 - = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon - eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = - checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") - eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition") - - eqCon c1 c2 - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "differ") `andThenCheck` - check (dataConIsInfix c1 == dataConIsInfix c2) - (text "The fixities of" <+> pname1 <+> - text "differ") `andThenCheck` - check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) - (text "The strictness annotations for" <+> pname1 <+> - text "differ") `andThenCheck` - check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) - (text "The record label lists for" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) - (text "The types for" <+> pname1 <+> text "differ") - where - name1 = dataConName c1 - name2 = dataConName c2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - - eqClosedFamilyAx Nothing Nothing = True - eqClosedFamilyAx Nothing (Just _) = False - eqClosedFamilyAx (Just _) Nothing = False - eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) - (Just (CoAxiom { co_ax_branches = branches2 })) - = numBranches branches1 == numBranches branches2 - && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) - where - branch_list1 = fromBranches branches1 - branch_list2 = fromBranches branches2 - - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 - , cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 - , cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 - , Just env <- eqVarBndrs env1 cvs1 cvs2 - = liftEq (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 - - | otherwise = False - -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet - ----------------- -missingBootThing :: Bool -> Name -> String -> TcRnMessage -missingBootThing is_boot name what - = mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is exported by the" - <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not" - <+> text what <+> text "the module" - -badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage -badReexportedBootThing is_boot name name' - = mkTcRnUnknownMessage $ mkPlainError noHints $ - withUserStyle alwaysQualify AllTheWay $ vcat - [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file (re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage -bootMisMatch is_boot extra_info real_thing boot_thing - = mkTcRnUnknownMessage $ mkPlainError noHints $ - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - where - to_doc - = pprTyThingInContext $ showToHeader { ss_forall = - if is_boot - then ShowForAllMust - else ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - = vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module", - text "and its" <+> - (if is_boot - then text "hs-boot file" - else text "hsig file"), - text "Main module:" <+> real_doc, - (if is_boot - then text "Boot file: " - else text "Hsig file: ") - <+> boot_doc, - extra_info - ] - -instMisMatch :: DFunId -> TcRnMessage -instMisMatch dfun - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "instance" <+> ppr (idType dfun)) - 2 (text "is defined in the hs-boot file, but not in the module itself") - -{- -************************************************************************ -* * - Type-checking the top level of a module (continued) -* * -************************************************************************ --} - -rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) --- Fails if there are any errors -rnTopSrcDecls group - = do { -- Rename the source decls - traceRn "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; - traceRn "rn13" empty ; - (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; - traceRn "rn13-plugin" empty ; - - -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; - - -- Dump trace of renaming part - rnDump rn_decls ; - return (tcg_env', rn_decls) - } - -tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_valds = hs_val_binds@(XValBindsLR - (NValBinds val_binds val_sigs)) }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2 (src)" empty ; - - -- Source-language instances, including derivings, - -- and import the supporting declarations - traceTc "Tc3" empty ; - (tcg_env, inst_infos, th_bndrs, - XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; - - updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ - setGblEnv tcg_env $ do { - - -- Generate Applicative/Monad proposal (AMP) warnings - traceTc "Tc3b" empty ; - - -- Generate Semigroup/Monoid warnings - traceTc "Tc3c" empty ; - tcSemigroupWarnings ; - - -- Foreign import declarations next. - traceTc "Tc4" empty ; - (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { - - -- Default declarations - traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Value declarations next. - -- It is important that we check the top-level value bindings - -- before the GHC-generated derived bindings, since the latter - -- may be defined in terms of the former. (For instance, - -- the bindings produced in a Data instance.) - traceTc "Tc5" empty ; - tc_envs <- tcTopBinds val_binds val_sigs; - restoreEnvs tc_envs $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs@(tcg_env, tcl_env) - <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; - restoreEnvs tc_envs $ do { -- Environment doesn't change now - - -- Second pass over class and instance declarations, - -- now using the kind-checked decls - traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; - - -- Foreign exports - traceTc "Tc7" empty ; - (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; - - -- Annotations - annotations <- tcAnnotations annotation_decls ; - - -- Rules - rules <- tcRules rule_decls ; - - -- Wrap up - traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds - - ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre) - emptyFVs fo_gres - - ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) - `minusNameSet` getTypeSigNames val_sigs - - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds - , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names - , tcg_rules = tcg_rules tcg_env - ++ flattenRuleDecls rules - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; - -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] - - -- See Note [Newtype constructor usage in foreign declarations] - addUsedGREs (bagToList fo_gres) ; - - return (tcg_env', tcl_env) - }}}}}} - -tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" - - -tcSemigroupWarnings :: TcM () -tcSemigroupWarnings = do - mod <- getModule - -- ghc-prim doesn't depend on base - unless (moduleUnit mod == primUnit) $ do - traceTc "tcSemigroupWarnings" empty - let warnFlag = Opt_WarnSemigroup - tcPreludeClashWarn warnFlag sappendName - tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName - - --- | Warn on local definitions of names that would clash with future Prelude --- elements. --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcPreludeClashWarn :: WarningFlag - -> Name - -> TcM () -tcPreludeClashWarn warnFlag name = do - { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcPreludeClashWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (importedViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (greMangledName x) == nameOccName name - -- ... but not the actual definitions, because we don't want to - -- warn about a bad definition of e.g. <> in Data.Semigroup, which - -- is the (only) proper place where this should be defined - isNotInProperModule = greMangledName x /= name - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcPreludeClashWarn/prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ - mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . greMangledName) x - , text "clashes with a future Prelude name." ] - $$ - text "This will become an error in a future release." ) - ; mapM_ warn_msg clashingElts - }}} - - where - - -- Is the given name imported via Prelude? - -- - -- Possible scenarios: - -- a) Prelude is imported implicitly, issue warnings. - -- b) Prelude is imported explicitly, but without mentioning the name in - -- question. Issue no warnings. - -- c) Prelude is imported hiding the name in question. Issue no warnings. - -- d) Qualified import of Prelude, no warnings. - importedViaPrelude :: Name - -> [ImportDecl GhcRn] - -> Bool - importedViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl GhcRn -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl GhcRn -> Bool - isImplicit = ideclImplicit . ideclExt - - -- Unqualified import? - isUnqualified :: ImportDecl GhcRn -> Bool - isUnqualified = not . isImportDeclQualified . ideclQualified - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, ) -> Explicit import list of - -- Just (True , ) -> Explicit hiding of - importListOf :: ImportDecl GhcRn -> Maybe (ImportListInterpretation, [Name]) - importListOf = fmap toImportList . ideclImportList - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl GhcRn -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (Exactly, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (EverythingBut, hidden) - -> nameOccName name `notElem` map nameOccName hidden - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl GhcRn -> Bool - importViaPrelude x = isPrelude x - && isUnqualified x - && (isImplicit x || isExplicit x) - - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. -tcMissingParentClassWarn :: WarningFlag - -> Name -- ^ Instances of this ... - -> Name -- ^ should also be instances of this - -> TcM () -tcMissingParentClassWarn warnFlag isName shouldName - = do { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcMissingParentClassWarn" empty - ; isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts (checkShouldInst isClass shouldClass) - } - (is',should') -> - traceTc "tcMissingParentClassWarn/notIsShould" - (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( - (hsep [ quotes (text "Is"), text "lookup for" - , ppr isName - , text "resulted in", ppr is' ]) - $$ - (hsep [ quotes (text "Should"), text "lookup for" - , ppr shouldName - , text "resulted in", ppr should' ]))) - }} - where - -- Check whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- Class of existing instance - -> Class -- Class there should be an instance of - -> ClsInst -- Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) - - ; traceTc "tcMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- ": Warning: is an instance of but not - -- " e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (RM_KnownTc name:_) = - addDiagnosticAt instLoc $ - mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ - hsep [ (quotes . ppr . nameOccName) name - , text "is an instance of" - , (ppr . nameOccName . className) isClass - , text "but not" - , (ppr . nameOccName . className) shouldClass ] - <> text "." - $$ - hsep [ text "This will become an error in" - , text "a future release." ] - warnMsg _ = pure () - ; when (nullUnifiers shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - tcLookupClass_maybe :: Name -> TcM (Maybe Class) - tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case - Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls - _else -> pure Nothing - - ---------------------------- -tcTyClsInstDecls :: [TyClGroup GhcRn] - -> [LDerivDecl GhcRn] - -> [(RecFlag, LHsBinds GhcRn)] - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to - -- process; contains all dfuns for - -- this module - ThBindEnv, -- TH binding levels - HsValBinds GhcRn) -- Supporting bindings for derived - -- instances - -tcTyClsInstDecls tycl_decls deriv_decls binds - = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ - tcAddPatSynPlaceholders (getPatSynBinds binds) $ - do { (tcg_env, inst_info, deriv_info, th_bndrs) - <- tcTyAndClassDecls tycl_decls ; - ; setGblEnv tcg_env $ do { - -- With the @TyClDecl@s and @InstDecl@s checked we're ready to - -- process the deriving clauses, including data family deriving - -- clauses discovered in @tcTyAndClassDecls@. - -- - -- Careful to quit now in case there were instance errors, so that - -- the deriving errors don't pile up as well. - ; failIfErrsM - ; (tcg_env', inst_info', val_binds) - <- tcInstDeclsDeriv deriv_info deriv_decls - ; setGblEnv tcg_env' $ do { - failIfErrsM - ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) - }}} - -{- ********************************************************************* -* * - Checking for 'main' -* * -************************************************************************ --} - -checkMainType :: TcGblEnv -> TcRn WantedConstraints --- If this is the Main module, and it defines a function main, --- check that its type is of form IO tau. --- If not, do nothing --- See Note [Dealing with main] -checkMainType tcg_env - = do { hsc_env <- getTopEnv - ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) - then return emptyWC else - - do { rdr_env <- getGlobalRdrEnv - ; let dflags = hsc_dflags hsc_env - main_occ = getMainOcc dflags - main_gres = lookupGlobalRdrEnv rdr_env main_occ - ; case filter isLocalGRE main_gres of { - [] -> return emptyWC ; - (_:_:_) -> return emptyWC ; - [main_gre] -> - - do { let main_name = greMangledName main_gre - ctxt = FunSigCtxt main_name NoRRC - ; main_id <- tcLookupId main_name - ; (io_ty,_) <- getIOType - ; let main_ty = idType main_id - eq_orig = TypeEqOrigin { uo_actual = main_ty - , uo_expected = io_ty - , uo_thing = Nothing - , uo_visible = True } - ; (_, lie) <- captureTopConstraints $ - setMainCtxt main_name io_ty $ - tcSubTypeSigma eq_orig ctxt main_ty io_ty - ; return lie } } } } - -checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [LIE GhcPs]) -- Export specs of Main module - -> TcM TcGblEnv --- If we are in module Main, check that 'main' is exported, --- and generate the runMainIO binding that calls it --- See Note [Dealing with main] -checkMain explicit_mod_hdr export_ies - = do { hsc_env <- getTopEnv - ; tcg_env <- getGblEnv - - ; let dflags = hsc_dflags hsc_env - main_mod = mainModIs (hsc_HUE hsc_env) - main_occ = getMainOcc dflags - - exported_mains :: [Name] - -- Exported things that are called 'main' - exported_mains = [ name | avail <- tcg_exports tcg_env - , name <- availNames avail - , nameOccName name == main_occ ] - - ; if | tcg_mod tcg_env /= main_mod - -> -- Not the main module - return tcg_env - - | [main_name] <- exported_mains - -> -- The module indeed exports a function called 'main' - generateMainBinding tcg_env main_name - - | otherwise - -> assert (null exported_mains) $ - -- A fully-checked export list can't contain more - -- than one function with the same OccName - do { complain_no_main dflags main_mod main_occ - ; return tcg_env } } - where - complain_no_main dflags main_mod main_occ - = unless (interactive && not explicit_mod_hdr) $ - addErrTc (noMainMsg main_mod main_occ) -- #12906 - where - interactive = ghcLink dflags == LinkInMemory - -- Without an explicit module header... - -- in interactive mode, don't worry about the absence of 'main'. - -- in other modes, add error message and go on with typechecking. - - noMainMsg main_mod main_occ - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "The" <+> ppMainFn main_occ - <+> text "is not" <+> text defOrExp <+> text "module" - <+> quotes (ppr main_mod) - - defOrExp | explicit_export_list = "exported by" - | otherwise = "defined in" - explicit_export_list = explicit_mod_hdr && isJust export_ies - --- | Get the unqualified name of the function to use as the \"main\" for the main module. --- Either returns the default name or the one configured on the command line with -main-is -getMainOcc :: DynFlags -> OccName -getMainOcc dflags = case mainFunIs dflags of - Just fn -> mkVarOccFS (mkFastString fn) - Nothing -> mainOcc - -ppMainFn :: OccName -> SDoc -ppMainFn main_occ - | main_occ == mainOcc - = text "IO action" <+> quotes (ppr main_occ) - | otherwise - = text "main IO action" <+> quotes (ppr main_occ) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") - -generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv --- There is a single exported 'main' function, called 'foo' (say), --- which may be locally defined or imported --- Define and typecheck the binding --- :Main.main :: IO res_ty = runMainIO res_ty foo --- This wraps the user's main function in the top-level stuff --- defined in runMainIO (eg catching otherwise un-caught exceptions) --- See Note [Dealing with main] -generateMainBinding tcg_env main_name = do - { traceTc "checkMain found" (ppr main_name) - ; (io_ty, res_ty) <- getIOType - ; let loc = getSrcSpan main_name - main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name)) - ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ - tcCheckMonoExpr main_expr_rn io_ty - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty - ; co = mkWpTyApps [res_ty] - -- The ev_binds of the `main` function may contain deferred - -- type errors when type of `main` is not `IO a`. The `ev_binds` - -- must be put inside `runMainIO` to ensure the deferred type - -- error can be emitted correctly. See #13838. - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ - mkHsDictLet ev_binds main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name - , tcg_binds = tcg_binds tcg_env - `snocBag` main_bind - , tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) }) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - } - -getIOType :: TcM (TcType, TcType) --- Return (IO alpha, alpha) for fresh alpha -getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; return (mkTyConApp ioTyCon [res_ty], res_ty) } - -setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) -setMainCtxt main_name io_ty thing_inside - = setSrcSpan (getSrcSpan main_name) $ - addErrCtxt main_ctxt $ - checkConstraints skol_info [] [] $ -- Builds an implication if necessary - thing_inside -- e.g. with -fdefer-type-errors - where - skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty [] - main_ctxt = text "When checking the type of the" - <+> ppMainFn (nameOccName main_name) - -{- Note [Dealing with main] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dealing with the 'main' declaration is surprisingly tricky. Here are -the moving parts: - -* The flag -main-is=M.foo allows you to set the main module to 'M', - and the main function to 'foo'. We access them through - mainModIs :: HscEnv -> Module -- returns M - getMainOcc :: DynFlags -> OccName -- returns foo - Of course usually M = Main, and foo = main. - -* checkMainType: when typechecking module M, we add an extra check that - foo :: IO tau, for some type tau. - This avoids getting ambiguous-type errors from the monomorphism restriction - applying to things like - main = return () - Note that checkMainType does not consult the export list because - we have not yet done rnExports (and can't do it until later). - -* rnExports: checks the export list. Very annoyingly, we can only do - this after running any finalisers, which may add new declarations. - That's why checkMainType and checkMain have to be separate. - -* checkMain: does two things: - - check that the export list does indeed export something called 'foo' - - generateMainBinding: generate the root-main binding - :Main.main = runMainIO M.foo - See Note [Root-main Id] - -An annoying consequence of having both checkMainType and checkMain is -that, when (but only when) -fdefer-type-errors is on, we may report an -ill-typed 'main' twice (as warnings): once in checkMainType and once -in checkMain. See test typecheck/should_fail/T13292. - -We have the following tests to check this processing: -----------------+----------------------------------------------------------------------------------+ - | Module Header: | - +-------------+-------------+-------------+-------------+-------------+------------+ - | module | module Main | | module Main |module |module Main | - | Main(main) | | | (module X)| Main () | (Sub.main)| -----------------+==================================================================================+ -`main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main | -in Main module | Ambiguous | | Ambiguous | | `main` not | | -and in imported | | | | | exported | | -module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 | - | | | | X = Main | Remark 2) | | -----------------+-------------+-------------+-------------+-------------+-------------+------------+ -`main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main | -only in imported| | No `main` in| | | `main` not | | -submodule Sub. | | `Main` | | | exported | | - | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 | - | | | | X = Sub | Remark 2) | | -----------------+-------------+-------------+-------------+-------------+-------------+------------+ -`foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo | -in submodule | | No `foo` in | | | `foo` not | | -Sub. | | `Main` | | | exported | | -GHC option: | | | | | | | - -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 | - | Remark 1) | | | X = Sub | | Remark 3) | -----------------+-------------+-------------+-------------+-------------+-------------+------------+ - -Remarks: -* The first line shows the exported `main` function or the error. -* The second line shows the coresponding test case. -* The module `Sub` contains the following functions: - main :: IO () - foo :: IO () -* Remark 1) Here the header is `Main (foo)`. -* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`. -* Remark 3) Here the header is `Main (Sub.foo)`. - - -Note [Root-main Id] -~~~~~~~~~~~~~~~~~~~ -The function that the RTS invokes is always :Main.main, which we call -root_main_id. (Because GHC allows the user to have a module not -called Main as the main module, we can't rely on the main function -being called "Main.main". That's why root_main_id has a fixed module -":Main".) - -This is unusual: it's a LocalId whose Name has a Module from another -module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we -get two defns for 'main' in the interface file! - -When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file. -When the interface is read back in we have to add a special case when creating the -Id because otherwise we would go looking for the :Main module which obviously doesn't -exist. For this logic see GHC.IfaceToCore.mk_top_id. - -There is also some similar (probably dead) logic in GHC.Rename.Env which says it -was added for External Core which faced a similar issue. - - -********************************************************* -* * - GHCi stuff -* * -********************************************************* --} - -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) --- Initialise the tcg_inst_env with instances from all home modules. --- This mimics the more selective call to hptInstances in tcRnImports -runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ - withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ - do { traceTc "setInteractiveContext" $ - vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) - , text "icReaderEnv (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) - , let local_gres = filter isLocalGRE gres - , not (null local_gres) ]) ] - - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - NotBoot mb_pkg) - - ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> - case i of -- force above: see #15111 - IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) - (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) - - ; let imports = emptyImportAvails { imp_orphs = orphs } - - upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') - where - gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt - , tcg_type_env = type_env - - , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports } - - lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids - - ; updEnvs upd_envs thing_inside } - where - (home_insts, home_fam_insts) = hptAllInstances hsc_env - - icxt = hsc_IC hsc_env - (ic_insts, ic_finsts) = ic_instances icxt - (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) - - is_closed :: TyThing -> Either (Name, TcTyThing) TyThing - -- Put Ids with free type variables (always RuntimeUnks) - -- in the *local* type environment - -- See Note [Initialising the type environment for GHCi] - is_closed thing - | AnId id <- thing - , not (isTypeClosedLetBndr id) - = Left (idName id, ATcId { tct_id = id - , tct_info = NotLetBound }) - | otherwise - = Right thing - - type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts)) - -- Putting the dfuns in the type_env - -- is just to keep Core Lint happy - - con_fields = [ (dataConName c, dataConFieldLabels c) - | ATyCon t <- top_ty_things - , c <- tyConDataCons t ] - - -{- Note [Initialising the type environment for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the Ids in ic_things, defined by the user in 'let' stmts, -have closed types. E.g. - ghci> let foo x y = x && not y - -However the GHCi debugger creates top-level bindings for Ids whose -types have free RuntimeUnk skolem variables, standing for unknown -types. If we don't register these free TyVars as global TyVars then -the typechecker will try to quantify over them and fall over in -skolemiseQuantifiedTyVar. so we must add any free TyVars to the -typechecker's global TyVar set. That is done by using -tcExtendLocalTypeEnv. - -We do this by splitting out the Ids with open types, using 'is_closed' -to do the partition. The top-level things go in the global TypeEnv; -the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the -local TypeEnv. - -Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope -things are already in the interactive context's GlobalRdrEnv. -Extending the local RdrEnv isn't terrible, but it means there is an -entry for the same Name in both global and local RdrEnvs, and that -lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). - -We don't bother with the tcl_th_bndrs environment either. --} - --- | The returned [Id] is the list of new Ids bound by this statement. It can --- be used to extend the InteractiveContext via extendInteractiveContext. --- --- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound --- values, coerced to (). -tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) -tcRnStmt hsc_env rdr_stmt - = runTcInteractive hsc_env $ do { - - -- The real work is done here - ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; - zonked_expr <- zonkTopLExpr tc_expr ; - zonked_ids <- zonkTopBndrs bound_ids ; - - failIfErrsM ; -- we can't do the next step if there are - -- representation polymorphism errors - -- test case: ghci/scripts/T13202{,a} - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ; - - traceTc "tcs 1" empty ; - this_mod <- getModule ; - global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; - -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env - - traceOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; - - return (global_ids, zonked_expr, fix_env) - } - where - bad_unboxed id = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) - -{- --------------------------------------------------------------------------- - Typechecking Stmts in GHCi - -Here is the grand plan, implemented in tcUserStmt - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] - - expr (of non-IO type, - result not showable) ==> error --} - --- | A plan is an attempt to lift some code into the IO monad. -type PlanResult = ([Id], LHsExpr GhcTc) -type Plan = TcM PlanResult - --- | Try the plans in order. If one fails (by raising an exn), try the next. --- If one succeeds, take it. -runPlans :: NonEmpty Plan -> Plan -runPlans = foldr1 (flip tryTcDiscardingErrs) - --- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the --- GHCi 'environment'. --- --- By 'lift' and 'environment we mean that the code is changed to --- execute properly in an IO monad. See Note [Interactively-bound Ids --- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying --- different ways ('plans') of lifting the code into the IO monad and --- type checking each plan until one succeeds. -tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) - --- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (BodyStmt _ expr _ _)) - = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) - - ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell - (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr) - -- Don't try to typecheck if the renamer fails! - ; ghciStep <- getGhciStepIO - ; uniq <- newUnique - ; let loc' = noAnnSrcSpan $ locA loc - ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq (locA loc) - matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr - emptyLocalBinds] - -- [it = expr] - the_bind = L loc $ (mkTopFunBind FromSource - (L loc' fresh_it) matches) - { fun_ext = fvs } - -- Care here! In GHCi the expression might have - -- free variables, and they in turn may have free type variables - -- (if we are at a breakpoint, say). We must put those free vars - - -- [let it = expr] - let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn - $ XValBindsLR - (NValBinds [(NonRecursive,unitBag the_bind)] []) - - -- [it <- e] - bind_stmt = L loc $ BindStmt - (XBindStmtRn - { xbsrn_bindOp = mkRnSyntaxExpr bindIOName - , xbsrn_failOp = Nothing - }) - (L loc (VarPat noExtField (L loc' fresh_it))) - (nlHsApp ghciStep rn_expr) - - -- [; print it] - print_it = L loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) - (nlHsVar fresh_it)) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- NewA - no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName - [rn_expr , nlHsVar interPrintName]) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_b = L loc $ BodyStmt noExtField (rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_c = L loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- See Note [GHCi Plans] - - it_plans = - -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM - ; return stuff } :| - - -- Plan B; a naked bind statement - [ tcGhciStmts [bind_stmt] - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } ] - - -- Plans where we don't bind "it" - no_it_plans = - tcGhciStmts [no_it_a] :| - tcGhciStmts [no_it_b] : - tcGhciStmts [no_it_c] : - [] - - ; generate_it <- goptM Opt_NoIt - - -- We disable `-fdefer-type-errors` in GHCi for naked expressions. - -- See Note [Deferred type errors in GHCi] - - -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` - -- and `-fdefer-out-of-scope-variables`. However the flag - -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and - -- `-fno-defer-out-of-scope-variables`. Thus the later two flags - -- also need to be unset here. - ; plan <- unsetGOptM Opt_DeferTypeErrors $ - unsetGOptM Opt_DeferTypedHoles $ - unsetGOptM Opt_DeferOutOfScopeVariables $ - runPlans $ if generate_it - then no_it_plans - else it_plans - - ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell - (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan) - - ; fix_env <- getFixityEnv - ; return (plan, fix_env) } - -{- Note [Deferred type errors in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHCi, we ensure that type errors don't get deferred when type checking the -naked expressions. Deferring type errors here is unhelpful because the -expression gets evaluated right away anyway. It also would potentially emit -two redundant type-error warnings, one from each plan. - -#14963 reveals another bug that when deferred type errors is enabled -in GHCi, any reference of imported/loaded variables (directly or indirectly) -in interactively issued naked expressions will cause ghc panic. See more -detailed discussion in #14963. - -The interactively issued declarations, statements, as well as the modules -loaded into GHCi, are not affected. That means, for declaration, you could -have - - Prelude> :set -fdefer-type-errors - Prelude> x :: IO (); x = putStrLn True - :14:26: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True - -But for naked expressions, you will have - - Prelude> :set -fdefer-type-errors - Prelude> putStrLn True - :2:10: error: - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘it’: it = putStrLn True - - Prelude> let x = putStrLn True - :2:18: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True --} - -tcUserStmt rdr_stmt@(L loc _) - = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do - fix_env <- getFixityEnv - return (fix_env, emptyFVs) - -- Don't try to typecheck if the renamer fails! - ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) - ; rnDump rn_stmt ; - - ; ghciStep <- getGhciStepIO - ; let gi_stmt - | (L loc (BindStmt x pat expr)) <- rn_stmt - = L loc $ BindStmt x pat (nlHsApp ghciStep expr) - | otherwise = rn_stmt - - ; opt_pr_flag <- goptM Opt_PrintBindResult - ; let print_result_plan - | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder - = Just $ mk_print_result_plan gi_stmt v - | otherwise = Nothing - - -- The plans are: - -- [stmt; print v] if one binder and not v::() - -- [stmt] otherwise - ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt] - ; return (plan, fix_env) } - where - mk_print_result_plan stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - where - print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) - (nlHsVar v)) - (mkRnSyntaxExpr thenIOName) noSyntaxExpr - -{- -Note [GHCi Plans] -~~~~~~~~~~~~~~~~~ -When a user types an expression in the repl we try to print it in three different -ways. Also, depending on whether -fno-it is set, we bind a variable called `it` -which can be used to refer to the result of the expression subsequently in the repl. - -The normal plans are : - A. [it <- e; print e] but not if it::() - B. [it <- e] - C. [let it = e; print it] - -When -fno-it is set, the plans are: - A. [e >>= print] - B. [e] - C. [let it = e in print it] - -The reason for -fno-it is explained in #14336. `it` can lead to the repl -leaking memory as it is repeatedly queried. --} - --- | Typecheck the statements given and then return the results of the --- statement in the form 'IO [()]'. -tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult -tcGhciStmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName - ; ret_id <- tcLookupId returnIOName -- return @ IO - ; let ret_ty = mkListTy unitTy - io_ret_ty = mkTyConApp ioTyCon [ret_ty] - tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts - (mkCheckExpType io_ret_ty) - names = collectLStmtsBinders CollNoDictBinders stmts - - -- OK, we're ready to typecheck the stmts - ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty - ; ((tc_stmts, ids), lie) <- captureTopConstraints $ - tc_io_stmts $ \ _ -> - mapM tcLookupId names - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty - ; const_binds <- checkNoErrs (simplifyInteractive lie) - -- checkNoErrs ensures that the plan fails if context redn fails - - - ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty - - -- ret_expr is the expression - -- returnIO @[()] [unsafeCoerce# () x, .., unsafeCoerce# () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - - ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName - -- We use unsafeCoerce# here because of (U11) in - -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - - ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLocA $ ExplicitList unitTy $ - map mk_item ids - - mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) - , getRuntimeRep unitTy - , idType id, unitTy] - `nlHsApp` nlHsVar id - stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] - - ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) - } - --- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -getGhciStepIO :: TcM (LHsExpr GhcRn) -getGhciStepIO = do - ghciTy <- getGHCiMonad - a_tv <- newName (mkTyVarOccFS (fsLit "a")) - let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) - ioM = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv) - - step_ty :: LHsSigType GhcRn - step_ty = noLocA $ HsSig - { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} - , sig_ext = noExtField - , sig_body = nlHsFunTy ghciM ioM } - - stepTy :: LHsSigWcType GhcRn - stepTy = mkEmptyWildCardBndrs step_ty - - return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) - -isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) -isGHCiMonad hsc_env ty - = runTcInteractive hsc_env $ do - rdrEnv <- getGlobalRdrEnv - let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) - case occIO of - Just [n] -> do - let name = greMangledName n - ghciClass <- tcLookupClass ghciIoClassName - userTyCon <- tcLookupTyCon name - let userTy = mkTyConApp userTyCon [] - _ <- tcLookupInstance ghciClass [userTy] - return name - - Just _ -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" - Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) - --- | How should we infer a type? See Note [TcRnExprMode] -data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) - | TM_Default -- ^ Instantiate all quantifiers, - -- and do eager defaulting (:type +d) - --- | tcRnExpr just finds the type of an expression --- for :type -tcRnExpr :: HscEnv - -> TcRnExprMode - -> LHsExpr GhcPs - -> IO (Messages TcRnMessage, Maybe Type) -tcRnExpr hsc_env mode rdr_expr - = runTcInteractive hsc_env $ - do { - - (rn_expr, _fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - - -- Typecheck the expression - ((tclvl, res_ty), lie) - <- captureTopConstraints $ - pushTcLevelM $ - tcInferSigma inst rn_expr ; - - -- Generalise - uniq <- newUnique ; - let { fresh_it = itName uniq (getLocA rdr_expr) } ; - ((qtvs, dicts, _, _), residual) - <- captureConstraints $ - simplifyInfer tclvl infer_mode - [] {- No sig vars -} - [(fresh_it, res_ty)] - lie ; - - -- Ignore the dictionary bindings - _ <- perhaps_disable_default_warnings $ - simplifyInteractive residual ; - - let { all_expr_ty = mkInfForAllTys qtvs $ - mkPhiTy (map idType dicts) res_ty } ; - ty <- zonkTcType all_expr_ty ; - - -- See Note [Normalising the type in :type] - fam_envs <- tcGetFamInstEnvs ; - let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty - -- normaliseType returns a coercion which we discard, so the Role is irrelevant. - ; final_type = if isSigmaTy res_ty then ty else normalised_type } ; - return final_type } - where - -- Optionally instantiate the type of the expression - -- See Note [TcRnExprMode] - (inst, infer_mode, perhaps_disable_default_warnings) = case mode of - TM_Inst -> (False, NoRestrictions, id) - TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - -{- Note [Implementing :type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider :type const - -We want forall a b. a -> b -> a -and not forall {a}{b}. a -> b -> a - -The latter is what we'd get if we eagerly instantiated and then -re-generalised with Inferred binders. It makes a difference, because -it tells us we where we can use Visible Type Application (VTA). - -And also for :type const @Int -we want forall b. Int -> b -> Int -and not forall {b}. Int -> b -> Int - -Solution: use tcInferSigma, which in turn uses tcInferApp, which -has a special case for application chains. - -Note [Normalising the type in :type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In :t we usually normalise the type (to simplify type functions) -before displaying the result. Reason (see #10321): otherwise we may show -types like - :: Vec (1+2) Int -rather than the simpler - :: Vec 3 Int -In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason. - -However this normalisation is less helpful when is just -an identifier, whose user-written type happens to contain type-function -applications. E.g. (#20974) - test :: F [Monad, A, B] m => m () -where F is a type family. If we say `:t test`, we'd prefer to see -the type family un-expanded. - -We adopt the following ad-hoc solution: if the type inferred for -(before generalisation, namely res_ty) is a SigmaType (i.e. is not -fully instantiated) then do not normalise; otherwise normalise. -This is not ideal; for example, suppose x :: F Int. Then - :t x -would be normalised because `F Int` is not a SigmaType. But -anything here is ad-hoc, and it's a user-sought improvement. --} - --------------------------- -tcRnImportDecls :: HscEnv - -> [LImportDecl GhcPs] - -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) --- Find the new chunk of GlobalRdrEnv created by this list of import --- decls. In contract tcRnImports *extends* the TcGblEnv. -tcRnImportDecls hsc_env import_decls - = runTcInteractive hsc_env $ - do { gbl_env <- updGblEnv zap_rdr_env $ - tcRnImports hsc_env $ map (,text "is directly imported") import_decls - ; return (tcg_rdr_env gbl_env) } - where - zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } - --- tcRnType just finds the kind of a type -tcRnType :: HscEnv - -> ZonkFlexi - -> Bool -- Normalise the returned type - -> LHsType GhcPs - -> IO (Messages TcRnMessage, Maybe (Type, Kind)) -tcRnType hsc_env flexi normalise rdr_type - = runTcInteractive hsc_env $ - setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (HsWC { hswc_ext = wcs, hswc_body = rn_sig_type@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body })) }, _fvs) - -- we are using 'rnHsSigWcType' to bind the unbound type variables - -- and in combination with 'tcOuterTKBndrs' we are able to - -- implicitly quantify them as if the user wrote 'forall' by - -- hand (see #19217). This allows kind check to work in presence - -- of free type variables : - -- ghci> :k [a] - -- [a] :: * - <- rnHsSigWcType GHCiCtx (mkHsWildCardBndrs $ noLocA (mkHsImplicitSigType rdr_type)) - -- The type can have wild cards, but no implicit - -- generalisation; e.g. :kind (T _) - ; failIfErrsM - - -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here - - -- Now kind-check the type - -- It can have any rank or kind - -- First bring into scope any wildcards - ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_sig_type]) - ; si <- mkSkolemInfo $ SigTypeSkol (GhciCtxt True) - ; ((_, (ty, kind)), wanted) - <- captureTopConstraints $ - pushTcLevelM_ $ - bindNamedWildCardBinders wcs $ \ wcs' -> - do { mapM_ emitNamedTypeHole wcs' - ; tcOuterTKBndrs si outer_bndrs $ tcInferLHsTypeUnsaturated body } - -- Since all the wanteds are equalities, the returned bindings will be empty - ; empty_binds <- simplifyTop wanted - ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) - - -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll unkSkol kind - - ; e <- mkEmptyZonkEnv flexi - ; ty <- zonkTcTypeToTypeX e ty - - -- Do validity checking on type - ; checkValidType (GhciCtxt True) ty - - -- Optionally (:k vs :k!) normalise the type. Does two things: - -- normaliseType: expand type-family applications - -- expandTypeSynonyms: expand type synonyms (#18828) - ; fam_envs <- tcGetFamInstEnvs - ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $ - normaliseType fam_envs Nominal ty - | otherwise = ty - - ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') - ; return (ty', mkInfForAllTys kvs (typeKind ty')) } - - -{- Note [TcRnExprMode] -~~~~~~~~~~~~~~~~~~~~~~ -How should we infer a type when a user asks for the type of an expression e -at the GHCi prompt? We offer 2 different possibilities, described below. Each -considers this example, with -fprint-explicit-foralls enabled. See also -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst - -:type / TM_Inst - - In this mode, we report the type obtained by instantiating only the - /inferred/ quantifiers of e's type, solving constraints, and - re-generalising, as discussed in #11376. - - > :type reverse - reverse :: forall a. [a] -> [a] - - -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - > :type foo @Int - forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String - - Note that Show Int is still reported, because the solver never got a chance - to see it. - -:type +d / TM_Default - - This mode is for the benefit of users who wish to see instantiations - of generalized types, and in particular to instantiate Foldable and - Traversable. In this mode, all type variables (inferred or - specified) are instantiated. Because GHCi uses - -XExtendedDefaultRules, this means that Foldable and Traversable are - defaulted. - - > :type +d reverse - reverse :: forall {a}. [a] -> [a] - - -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - > :type +d foo @Int - Int -> [Integer] -> String - - Note that this mode can sometimes lead to a type error, if a type variable is - used with a defaultable class but cannot actually be defaulted: - - bar :: (Num a, Monoid a) => a -> a - > :type +d bar - ** error ** - - The error arises because GHC tries to default a but cannot find a concrete - type in the defaulting list that is both Num and Monoid. (If this list is - modified to include an element that is both Num and Monoid, the defaulting - would succeed, of course.) - - Note that the variables and constraints are reordered here, because this - is possible during regeneralization. Also note that the variables are - reported as Inferred instead of Specified. - -Note [Kind-generalise in tcRnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We switch on PolyKinds when kind-checking a user type, so that we will -kind-generalise the type, even when PolyKinds is not otherwise on. -This gives the right default behaviour at the GHCi prompt, where if -you say ":k T", and T has a polymorphic kind, you'd like to see that -polymorphism. Of course. If T isn't kind-polymorphic you won't get -anything unexpected, but the apparent *loss* of polymorphism, for -types that you know are polymorphic, is quite surprising. See Trac -#7688 for a discussion. - -Note that the goal is to generalise the *kind of the type*, not -the type itself! Example: - ghci> data SameKind :: k -> k -> Type - ghci> :k SameKind _ - -We want to get `k -> Type`, not `Any -> Type`, which is what we would -get without kind-generalisation. Note that `:k SameKind` is OK, as -GHC will not instantiate SameKind here, and so we see its full kind -of `forall k. k -> k -> Type`. - -************************************************************************ -* * - tcRnDeclsi -* * -************************************************************************ - -tcRnDeclsi exists to allow class, data, and other declarations in GHCi. --} - -tcRnDeclsi :: HscEnv - -> [LHsDecl GhcPs] - -> IO (Messages TcRnMessage, Maybe TcGblEnv) -tcRnDeclsi hsc_env local_decls - = runTcInteractive hsc_env $ - tcRnSrcDecls False Nothing local_decls - -externaliseAndTidyId :: Module -> Id -> TcM Id -externaliseAndTidyId this_mod id - = do { name' <- externaliseName this_mod (idName id) - ; return $ globaliseId id - `setIdName` name' - `setIdType` tidyTopType (idType id) } - - -{- -************************************************************************ -* * - More GHCi stuff, to do with browsing and getting info -* * -************************************************************************ --} - --- | ASSUMES that the module is either in the 'HomePackageTable' or is --- a package module with an interface on disk. If neither of these is --- true, then the result will be an error indicating the interface --- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) -getModuleInterface hsc_env mod - = runTcInteractive hsc_env $ - loadModuleInterface (text "getModuleInterface") mod - -tcRnLookupRdrName :: HscEnv -> LocatedN RdrName - -> IO (Messages TcRnMessage, Maybe [Name]) --- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (L loc rdr_name) - = runTcInteractive hsc_env $ - setSrcSpanA loc $ - do { -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let rdr_names = dataTcOccs rdr_name - ; names_s <- mapM lookupInfoOccRn rdr_names - ; let names = concat names_s - ; when (null names) (addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Not in scope:" <+> quotes (ppr rdr_name))) - ; return names } - -tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) -tcRnLookupName hsc_env name - = runTcInteractive hsc_env $ - tcRnLookupName' name - --- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. --- But we also want a TyThing, so we have to convert: - -tcRnLookupName' :: Name -> TcRn TyThing -tcRnLookupName' name = do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - -tcRnGetInfo :: HscEnv - -> Name - -> IO ( Messages TcRnMessage - , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) - --- Used to implement :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env name - = runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) - - ; thing <- tcRnLookupName' name - ; fixity <- lookupFixityRn name - ; (cls_insts, fam_insts) <- lookupInsts thing - ; let info = lookupKnownNameInfo name - ; return (thing, fixity, cls_insts, fam_insts, info) } - - --- Lookup all class and family instances for a type constructor. --- --- This function filters all instances in the type environment, so there --- is a lot of duplicated work if it is called many times in the same --- type environment. If this becomes a problem, the NameEnv computed --- in GHC.getNameToInstancesIndex could be cached in TcM and both functions --- could be changed to consult that index. -lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) -lookupInsts (ATyCon tc) - = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - - -- Return only the instances relevant to the given thing, i.e. - -- the instances whose head contains the thing's name. - ; let cls_insts = - [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , instIsVisible vis_mods ispec - , tc_name `elemNameSet` orphNamesOfClsInst ispec ] - ; let fam_insts = - [ fispec - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , tc_name `elemNameSet` orphNamesOfFamInst fispec ] - ; return (cls_insts, fam_insts) } - where - tc_name = tyConName tc - -lookupInsts _ = return ([],[]) - -loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () --- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for --- something -loadUnqualIfaces hsc_env ictxt - = initIfaceTcRn $ - mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) - where - home_unit = hsc_home_unit hsc_env - - unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (icReaderEnv ictxt) - , let name = greMangledName gre - , nameIsFromExternalPackage home_unit name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - doc = text "Need interface for module whose export(s) are in scope unqualified" - - - -{- -************************************************************************ -* * - Debugging output - This is what happens when you do -ddump-types -* * -************************************************************************ --} - --- | Dump, with a banner, if -ddump-rn -rnDump :: (Outputable a, Data a) => a -> TcRn () -rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) - -tcDump :: TcGblEnv -> TcRn () -tcDump env - = do { unit_state <- hsc_units <$> getTopEnv ; - logger <- getLogger ; - - -- Dump short output if -ddump-types or -ddump-tc - when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) - (dumpTcRn True Opt_D_dump_types - "" FormatText (pprWithUnitState unit_state short_dump)) ; - - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; - - -- Dump bindings as an hsSyn AST if -ddump-tc-ast - dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump - } - where - short_dump = pprTcGblEnv env - full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords - ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env) - --- It's unpleasant having both pprModGuts and pprModDetails here -pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) - = getPprDebug $ \debug -> - vcat [ ppr_types debug type_env - , ppr_tycons debug fam_insts type_env - , ppr_datacons debug type_env - , ppr_patsyns type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , ppr_rules rules - , text "Dependent modules:" <+> - (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) - , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] - -- The use of sort is just to reduce unnecessary - -- wobbling in testsuite output - -ppr_rules :: [LRuleDecl GhcTc] -> SDoc -ppr_rules rules - = ppUnless (null rules) $ - hang (text "RULES") - 2 (vcat (map ppr rules)) - -ppr_types :: Bool -> TypeEnv -> SDoc -ppr_types debug type_env - = ppr_things "TYPE SIGNATURES" ppr_sig - (sortBy (comparing getOccName) ids) - where - ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id - | debug = True - | otherwise = hasTopUserName id - && case idDetails id of - VanillaId -> True - WorkerLikeId{} -> True - RecSelId {} -> True - ClassOpId {} -> True - FCallId {} -> True - _ -> False + checkBootDeclM, + getRenamedStuff, RenamedStuff + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.Plugins +import GHC.Driver.DynFlags +import GHC.Driver.Config.Diagnostic + +import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) +import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Validity( checkValidType ) +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) +import GHC.Tc.Zonk.Type +import GHC.Tc.Gen.Expr +import GHC.Tc.Gen.App( tcInferSigma ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Export +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Instance.Family +import GHC.Tc.Gen.Annotation +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Default +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Rule +import GHC.Tc.Gen.Foreign +import GHC.Tc.TyCl.Instance +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.TyCl +import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) +import GHC.Tc.Utils.Backpack +import GHC.Tc.Zonk.TcType + +import GHC.Rename.Bind ( rejectBootDecls ) +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Rename.HsType +import GHC.Rename.Expr +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Module +import GHC.Rename.Doc +import GHC.Rename.Utils ( mkNameClashErr ) + +import GHC.Iface.Decl ( coAxiomToIfaceDecl ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Iface.Load + +import GHC.Builtin.Types ( mkListTy, anyTypeOfKind ) +import GHC.Builtin.Names +import GHC.Builtin.Utils + +import GHC.Hs hiding ( FunDep(..) ) +import GHC.Hs.Dump + +import GHC.Core.PatSyn +import GHC.Core.Predicate ( classMethodTy ) +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.Reduction ( Reduction(..) ) +import GHC.Core.TyCo.Ppr( debugPprType ) +import GHC.Core.FamInstEnv + ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst + , famInstEnvElts, extendFamInstEnvList, normaliseType ) + +import GHC.Parser.Header ( mkPrelImports ) + +import GHC.IfaceToCore + +import GHC.Runtime.Context + +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc +import GHC.Utils.Logger + +import GHC.Types.Error +import GHC.Types.Name.Reader +import GHC.Types.Fixity.Env +import GHC.Types.Id as Id +import GHC.Types.Id.Info( IdDetails(..) ) +import GHC.Types.Var.Env +import GHC.Types.TypeEnv +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Annotations +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.PkgQual +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Unit.External +import GHC.Unit.Types +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Deps + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps +import GHC.Data.Bag +import qualified GHC.Data.BooleanFormula as BF + +import Control.Arrow ( second ) +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans.Writer.CPS +import Data.Data ( Data ) +import Data.Functor.Classes ( liftEq ) +import Data.List ( sortBy, sort ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Data.Ord +import qualified Data.Set as S +import Data.Foldable ( for_ ) +import Data.Traversable ( for ) + + + +{- +************************************************************************ +* * + Typecheck and rename a module +* * +************************************************************************ +-} + +-- | Top level entry point for typechecker and renamer +tcRnModule :: HscEnv + -> ModSummary + -> Bool -- True <=> save renamed syntax + -> HsParsedModule + -> IO (Messages TcRnMessage, Maybe TcGblEnv) + +tcRnModule hsc_env mod_sum save_rn_syntax + parsedModule@HsParsedModule {hpm_module= L loc this_module} + | RealSrcSpan real_loc _ <- loc + = withTiming logger + (text "Renamer/typechecker"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ + withHoleFitPlugins hsc_env $ + + tcRnModuleTcRnM hsc_env mod_sum parsedModule pair + + | otherwise + = return (err_msg `addMessage` emptyMessages, Nothing) + + where + hsc_src = ms_hsc_src mod_sum + logger = hsc_logger hsc_env + home_unit = hsc_home_unit hsc_env + err_msg = mkPlainErrorMsgEnvelope loc $ + TcRnModMissingRealSrcSpan this_mod + + pair :: (Module, SrcSpan) + pair@(this_mod,_) + | Just (L mod_loc mod) <- hsmodName this_module + = (mkHomeModule home_unit mod, locA mod_loc) + + | otherwise -- 'module M where' is omitted + = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) + + + + +tcRnModuleTcRnM :: HscEnv + -> ModSummary + -> HsParsedModule + -> (Module, SrcSpan) + -> TcRn TcGblEnv +-- Factored out separately from tcRnModule so that a Core plugin can +-- call the type checker directly +tcRnModuleTcRnM hsc_env mod_sum + (HsParsedModule { + hpm_module = + (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr) + maybe_mod export_ies import_decls local_decls)), + hpm_src_files = src_files + }) + (this_mod, prel_imp_loc) + = setSrcSpan loc $ + do { let { explicit_mod_hdr = isJust maybe_mod + ; hsc_src = ms_hsc_src mod_sum } + ; -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + tcg_env <- getGblEnv + ; boot_info <- tcHiBootIface hsc_src this_mod + ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) + $ do + { -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM LangExt.ImplicitPrelude + ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } + + ; when (notNull prel_imports) $ do + addDiagnostic TcRnImplicitImportOfPrelude + + ; -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = + ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) + , reLoc $ ideclName idecl) + } + ; raw_sig_imports <- liftIO + $ findExtraSigImports hsc_env hsc_src + (moduleName this_mod) + ; raw_req_imports <- liftIO + $ implicitRequirements hsc_env + (map simplifyImport (prel_imports + ++ import_decls)) + ; let { mkImport mod_name = noLocA + $ (simpleImportDecl mod_name) + { ideclImportList = Just (Exactly, noLocA [])}} + ; let { withReason t imps = map (,text t) imps } + ; let { all_imports = withReason "is implicitly imported" prel_imports + ++ withReason "is directly imported" import_decls + ++ withReason "is an extra sig import" (map mkImport raw_sig_imports) + ++ withReason "is an implicit req import" (map mkImport raw_req_imports) } + ; -- OK now finally rename the imports + tcg_env <- {-# SCC "tcRnImports" #-} + tcRnImports hsc_env all_imports + + -- Put a version of the header without identifier info into the tcg_env + -- Make sure to do this before 'tcRnSrcDecls', because we need the + -- module header when we're splicing TH, since it can be accessed via + -- 'getDoc'. + -- We will rename it properly after renaming everything else so that + -- haddock can link the identifiers + ; tcg_env <- return (tcg_env + { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) + <$> maybe_doc_hdr }) + ; -- If the whole module is warned about or deprecated + -- (via mod_deprec) record that in tcg_warns. If we do thereby add + -- a WarnAll, it will override any subsequent deprecations added to tcg_warns + ; tcg_env1 <- case mod_deprec of + Just (L _ txt) -> do { txt' <- rnWarningTxt txt + ; pure $ tcg_env {tcg_warns = WarnAll txt'} + } + Nothing -> pure tcg_env + ; setGblEnv tcg_env1 + $ do { -- Rename and type check the declarations + traceRn "rn1a" empty + ; tcg_env <- + case hsc_src of + HsBootOrSig boot_or_sig -> + do { tcg_env <- tcRnHsBootDecls boot_or_sig local_decls + ; traceRn "rn4a: before exports" empty + ; tcg_env <- setGblEnv tcg_env $ + rnExports explicit_mod_hdr export_ies + ; traceRn "rn4b: after exports" empty + ; return tcg_env + } + HsSrcFile -> + {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr export_ies local_decls + + ; whenM (goptM Opt_DoCoreLinting) $ + lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env + + ; setGblEnv tcg_env + $ do { -- Compare hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_info + ; -- The new type env is already available to stuff + -- slurped from interface files, via + -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this + -- includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for + -- boot_dfuns, which may be mentioned in imported + -- unfoldings. + ; -- Report unused names + -- Do this /after/ type inference, so that when reporting + -- a function with no type signature we can give the + -- inferred type + ; reportUnusedNames tcg_env hsc_src + + -- Rename the module header properly after we have renamed everything else + ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr; + ; tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + + ; -- add extra source files to tcg_dependent_files + addDependentFiles src_files + -- Ensure plugins run with the same tcg_env that we pass in + ; setGblEnv tcg_env + $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env + ; -- Dump output and return + tcDump tcg_env + ; return tcg_env + } + } + } + } + } + +{- +************************************************************************ +* * + Import declarations +* * +************************************************************************ +-} + +tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv +tcRnImports hsc_env import_decls + = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; + + ; this_mod <- getModule + ; gbl_env <- getGblEnv + ; let { -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file. This + -- filtering also ensures that we don't see instances from + -- modules batch (@--make@) compiled before this one, but + -- which are not below this one. + ; (home_insts, home_fam_insts) = + + hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env))) + + } ; + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { + updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports } + } + + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { + tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = rn_imports, + tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { + + ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module (including orphan family + -- instance-module) interfaces, so that their rules and + -- instance decls will be found. But filter out a + -- self hs-boot: these instances will be checked when + -- we define them locally. + -- (We don't need to load non-orphan family instance + -- modules until we either try to use the instances they + -- define, or define our own family instances, at which + -- point we need to check them for consistency.) + ; loadModuleInterfaces (text "Loading orphan modules") + (filter (/= this_mod) (imp_orphs imports)) + + -- Check type-family consistency between imports. + -- See Note [The type family instance consistency story] + ; traceRn "rn1: checking family instance consistency {" empty + ; let { dir_imp_mods = moduleEnvKeys + . imp_mods + $ imports } + ; checkFamInstConsistency dir_imp_mods + ; traceRn "rn1: } checking family instance consistency" empty + + ; getGblEnv } } + +{- +************************************************************************ +* * + Type-checking the top level of a module +* * +************************************************************************ +-} + +tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (LocatedL [LIE GhcPs]) + -> [LHsDecl GhcPs] -- Declarations + -> TcM TcGblEnv +tcRnSrcDecls explicit_mod_hdr export_ies decls + = do { -- Do all the declarations + ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls + + ------ Simplify constraints --------- + -- + -- We do this after checkMainType, so that we use the type + -- info that checkMainType adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop, + -- and affects how names are rendered in error messages + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + ; new_ev_binds <- {-# SCC "simplifyTop" #-} + restoreEnvs (tcg_env, tcl_env) $ + do { lie_main <- checkMainType tcg_env + ; simplifyTop (lie `andWC` lie_main) } + + -- Emit Typeable bindings + ; tcg_env <- setGblEnv tcg_env $ + mkTypeableBinds + + ; traceTc "Tc9" empty + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + ; (id_env, ev_binds', binds', fords', imp_specs', rules') + <- zonkTcGblEnv new_ev_binds tcg_env + + --------- Run finalizers -------------- + -- Finalizers must run after constraints are simplified, lest types + -- might not be complete when using reify (see #12777). + -- and also after we zonk the first time because we run typed splices + -- in the zonker which gives rise to the finalisers. + ; let -- init_tcg_env: + -- * Remove accumulated bindings, rules and so on from + -- TcGblEnv. They are now in ev_binds', binds', etc. + -- * Add the zonked Ids from the value bindings to tcg_type_env + -- Up to now these Ids are only in tcl_env's type-envt + init_tcg_env = tcg_env { tcg_binds = emptyBag + , tcg_ev_binds = emptyBag + , tcg_imp_specs = [] + , tcg_rules = [] + , tcg_fords = [] + , tcg_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env } + ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env + run_th_modfinalizers + ; finishTH + ; traceTc "Tc11" empty + + --------- Deal with the exports ---------- + -- Can't be done earlier, because the export list must "see" + -- the declarations created by the finalizers + ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ + rnExports explicit_mod_hdr export_ies + + --------- Emit the ':Main.main = runMainIO main' declaration ---------- + -- Do this /after/ rnExports, so that it can consult + -- the tcg_exports created by rnExports + ; (tcg_env, main_ev_binds) + <- restoreEnvs (tcg_env, tcl_env) $ + do { (tcg_env, lie) <- captureTopConstraints $ + checkMain explicit_mod_hdr export_ies + ; ev_binds <- simplifyTop lie + ; return (tcg_env, ev_binds) } + + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + + ---------- Final zonking --------------- + -- Zonk the new bindings arising from running the finalisers, + -- and main. This won't give rise to any more finalisers as you + -- can't nest finalisers inside finalisers. + ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + <- zonkTcGblEnv main_ev_binds tcg_env + + ; let { !final_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env_mf + -- Add the zonked Ids from the value bindings (they were in tcl_env) + -- Force !final_type_env, lest we retain an old reference + -- to the previous tcg_env + + ; tcg_env' = tcg_env + { tcg_binds = binds' `unionBags` binds_mf + , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf + , tcg_imp_specs = imp_specs' ++ imp_specs_mf + , tcg_rules = rules' ++ rules_mf + , tcg_fords = fords' ++ fords_mf } } ; + + ; setGlobalTypeEnv tcg_env' final_type_env + } + +zonkTcGblEnv :: Bag EvBind -> TcGblEnv + -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, + [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) +zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds + , tcg_ev_binds = cur_ev_binds + , tcg_imp_specs = imp_specs + , tcg_rules = rules + , tcg_fords = fords }) + = {-# SCC "zonkTopDecls" #-} + setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering + -- error messages during zonking (notably levity errors) + do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds + ; zonkTopDecls all_ev_binds binds rules imp_specs fords } + +-- | Runs TH finalizers and renames and typechecks the top-level declarations +-- that they could introduce. +run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) +run_th_modfinalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + th_modfinalizers <- readTcRef th_modfinalizers_var + if null th_modfinalizers + then getEnvs + else do + writeTcRef th_modfinalizers_var [] + let run_finalizer (lcl_env, f) = + restoreLclEnv lcl_env (runRemoteModFinalizers f) + + (_, lie_th) <- captureTopConstraints $ + mapM_ run_finalizer th_modfinalizers + + -- Finalizers can add top-level declarations with addTopDecls, so + -- we have to run tc_rn_src_decls to get them + (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] + + restoreEnvs (tcg_env, tcl_env) $ do + -- Subsequent rounds of finalizers run after any new constraints are + -- simplified, or some types might not be complete when using reify + -- (see #12777). + new_ev_binds <- {-# SCC "simplifyTop2" #-} + simplifyTop (lie_th `andWC` lie_top_decls) + addTopEvBinds new_ev_binds run_th_modfinalizers + -- addTopDecls can add declarations which add new finalizers. + +tc_rn_src_decls :: [LHsDecl GhcPs] + -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +-- Never emits constraints; calls captureTopConstraints internally +tc_rn_src_decls ds + = {-# SCC "tc_rn_src_decls" #-} + do { (first_group, group_tail) <- findSplice ds + -- If ds is [] we get ([], Nothing) + + -- Deal with decls up to, but not including, the first splice + ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group + -- rnTopSrcDecls fails if there are any errors + + -- Get TH-generated top-level declarations and make sure they don't + -- contain any splices since we don't handle that at the moment + -- + -- The plumbing here is a bit odd: see #10853 + ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + ; th_ds <- readTcRef th_topdecls_var + ; writeTcRef th_topdecls_var [] + + ; (tcg_env, rn_decls) <- + if null th_ds + then return (tcg_env, rn_decls) + else do { (th_group, th_group_tail) <- findSplice th_ds + ; case th_group_tail of + { Nothing -> return () + ; Just (SpliceDecl _ (L loc _) _, _) -> + setSrcSpanA loc $ addErr $ + TcRnTHError $ AddTopDeclsError + AddTopDeclsUnexpectedDeclarationSplice + } + -- Rename TH-generated top-level declarations + ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env + $ rnTopSrcDecls th_group + + -- Dump generated top-level declarations + ; let msg = "top-level declarations added with 'addTopDecls'" + ; traceSplice + $ SpliceInfo { spliceDescription = msg + , spliceIsDecl = True + , spliceSource = Nothing + , spliceGenerated = ppr th_rn_decls } + ; return (tcg_env, appendGroups rn_decls th_rn_decls) + } + + -- Type check all declarations + -- NB: set the env **before** captureTopConstraints so that error messages + -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that + -- the captureTopConstraints must go here, not in tcRnSrcDecls. + ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ + captureTopConstraints $ + tcTopSrcDecls rn_decls + + -- If there is no splice, we're nearly done + ; restoreEnvs (tcg_env, tcl_env) $ + case group_tail of + { Nothing -> return (tcg_env, tcl_env, lie1) + + -- If there's a splice, we must carry on + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> + do { + -- We need to simplify any constraints from the previous declaration + -- group, or else we might reify metavariables, as in #16980. + ; ev_binds1 <- simplifyTop lie1 + + -- Rename the splice expression, and get its supporting decls + ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice + + -- Glue them on the front of the remaining decls and loop + ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + addTopEvBinds ev_binds1 $ + tc_rn_src_decls (spliced_decls ++ rest_ds) + } + } + } + +{- +************************************************************************ +* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +* * +************************************************************************ +-} + +tcRnHsBootDecls :: HsBootOrSig -> [LHsDecl GhcPs] -> TcM TcGblEnv +tcRnHsBootDecls boot_or_sig decls + = do { (first_group, group_tail) <- findSplice decls + + -- Rename the declarations + ; (tcg_env, HsGroup { hs_tyclds = tycl_decls + , hs_derivds = deriv_decls + , hs_fords = for_decls + , hs_defds = def_decls + , hs_ruleds = rule_decls + , hs_annds = _ + , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) + <- rnTopSrcDecls first_group + + ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { + -- NB: setGblEnv **before** captureTopConstraints so that + -- if the latter reports errors, it knows what's in scope + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl _ d _, _) -> rejectBootDecls boot_or_sig BootSpliceDecls [d] + Nothing -> return () + ; rejectBootDecls boot_or_sig BootForeignDecls for_decls + ; rejectBootDecls boot_or_sig BootDefaultDecls def_decls + ; rejectBootDecls boot_or_sig BootRuleDecls rule_decls + + -- Typecheck type/class/instance decls + ; traceTc "Tc2 (boot)" empty + ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) + <- tcTyClsInstDecls tycl_decls deriv_decls val_binds + ; setGblEnv tcg_env $ do { + + -- Emit Typeable bindings + ; tcg_env <- mkTypeableBinds + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds val_sigs + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 + }}} + ; traceTc "boot" (ppr lie); return gbl_env } + +{- +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). +-} + +checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. + +checkHiBootIface tcg_env boot_info + | NoSelfBoot <- boot_info -- Common case + = return tcg_env + + | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! + = return tcg_env + + | SelfBoot { sb_mds = boot_details } <- boot_info + , TcGblEnv { tcg_binds = binds + , tcg_insts = local_insts + , tcg_type_env = local_type_env + , tcg_exports = local_exports } <- tcg_env + = do { -- This code is tricky, see Note [DFun knot-tying] + ; imp_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + + -- Now add the impedance-matching boot bindings: + -- + -- - dfun bindings $fxblah = $fblah + -- - record bindings fld{var} = fld{rec field of ..} + -- + -- to (a) the type envt, and (b) the top-level bindings + ; let boot_impedance_bds = map fst imp_prs + type_env' = extendTypeEnvWithIds local_type_env boot_impedance_bds + impedance_binds = listToBag [ mkVarBind boot_id (nlHsVar id) + | (boot_id, id) <- imp_prs ] + tcg_env_w_binds + = tcg_env { tcg_binds = binds `unionBags` impedance_binds } + + ; type_env' `seq` + -- Why the seq? Without, we will put a TypeEnv thunk in + -- tcg_type_env_var. That thunk will eventually get + -- forced if we are typechecking interfaces, but that + -- is no good if we are trying to typecheck the very + -- DFun we were going to put in. + -- TODO: Maybe setGlobalTypeEnv should be strict. + setGlobalTypeEnv tcg_env_w_binds type_env' } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "checkHiBootIface: unreachable code" +#endif + +{- Note [DFun impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We return a list of "impedance-matching" bindings for the dfuns +defined in the hs-boot file, such as + $fxEqT = $fEqT +We need these because the module and hi-boot file might differ in +the name it chose for the dfun: the name of a dfun is not +uniquely determined by its type; there might be multiple dfuns +which, individually, would map to the same name (in which case +we have to disambiguate them.) There's no way for the hi file +to know exactly what disambiguation to use... without looking +at the hi-boot file itself. + +In fact, the names will always differ because we always pick names +prefixed with "$fx" for boot dfuns, and "$f" for real dfuns +(so that this impedance matching is always possible). + +Note [Record field impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a hs-boot file defines a function whose implementation in the hs file +is a record selector, we have to do something similar to Note [DFun impedance matching]. + +Example: + + -- M.hs-boot + module M where + data A + fld :: A -> () + + -- M.hs + module M where + data A = MkA { fld :: () } + +Recall from Note [Record field namespacing] in GHC.Types.Name.Occurrence that +record fields have their own namespaces. This means that M.hs exports the Id +fld{record selector of MkA} :: A -> (), while M.hs-boot exports the Id +fld{variable} :: A -> (). + +To remedy this, we add an impedance-matching binding in M.hs: + + fld{variable} :: A -> () + fld{variable} = fld{record selector of MkA} + +Note that we imperatively need to add a binding for fld{variable} in M.hs, as we +might have an exact Name reference to it (e.g. in a module that imports M.hs-boot). +Not doing so would cause Core Lint errors, at the very least. + +These bindings are returned by the check_export in checkHiBootIface', and +added to the DFun impedance-matching bindings. + +[Wrinkle: exports] + + We MUST NOT add fld{variable} to the export list of M.hs, as this + would mean that M.hs exports both a record field and variable with the same + occNameFS, which would cause ambiguity errors at use-sites. + It's OK to only export the field name even though the boot-file exported + the variable: name resolution will take care of that. + +Another situation is that we are re-exporting, e.g. (with M as above): + + -- N.hs-boot + module N ( module M ) where + import {-# SOURCE #-} M + + -- N.hs + module N ( module M where ) + import M + +In this case, N.hs-boot re-exports the variable fld, and N re-exports the +record field fld, but not the variable fld. We don't need to do anything in +this situation; in particular, don't re-export the variable name from N.hs, +as per [Wrinkle: exports] above. + +Note [DFun knot-tying] +~~~~~~~~~~~~~~~~~~~~~~ +The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from +typechecking the hi-boot file that we are presently implementing. +Suppose we are typechecking the module A: when we typecheck the +hi-boot file, whenever we see an identifier A.T, we knot-tie this +identifier to the *local* type environment (via if_rec_types.) The +contract then is that we don't *look* at 'SelfBootInfo' until we've +finished typechecking the module and updated the type environment with +the new tycons and ids. + +This most works well, but there is one problem: DFuns! We do not want +to look at the mb_insts of the ModDetails in SelfBootInfo, because a +dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a +(lazily evaluated) lookup in the if_rec_types. We could extend the +type env, do a setGloblaTypeEnv etc; but that all seems very indirect. +It is much more directly simply to extract the DFunIds from the +md_types of the SelfBootInfo. + +See #4003, #16038 for why we need to take care here. +-} + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [(Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_types = boot_type_env + , md_fam_insts = boot_fam_insts + , md_exports = boot_exports }) + = do { traceTc "checkHiBootIface" $ vcat + [ ppr boot_type_env, ppr boot_exports ] + + ; gre_env <- getGlobalRdrEnv + + -- Check the exports of the boot module, one by one + ; fld_prs <- mapMaybeM (check_export gre_env) boot_exports + + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... + + -- Check instance declarations + -- and generate an impedance-matching binding + ; dfun_prs <- mapMaybeM check_cls_inst boot_dfuns + + ; failIfErrsM + + ; return (fld_prs ++ dfun_prs) } + + where + boot_dfun_names = map idName boot_dfuns + boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env + -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts + -- We don't want to look at md_insts! + -- Why not? See Note [DFun knot-tying] + + check_export gre_env boot_avail -- boot_avail is exported by the boot iface + | name `elem` boot_dfun_names + = return Nothing + + -- Check that the actual module exports the same thing + | missing_name:_ <- missing_names + = -- Lookup might have failed because the hs-boot file defines a variable + -- that is implemented in the hs file as a record selector, which + -- lives in a different namespace. + -- + -- See Note [Record field impedance matching]. + let missing_occ = nameOccName missing_name + mb_ok :: GlobalRdrElt -> Maybe (GlobalRdrElt, Maybe Id) + mb_ok gre + -- Ensure that this GRE refers to an Id that is exported. + | isNothing $ lookupNameEnv local_export_env (greName gre) + = Nothing + -- We locally define the field: create an impedance-matching + -- binding for the variable. + | Just (AnId id) <- lookupTypeEnv local_type_env (greName gre) + = Just (gre, Just id) + -- We are re-exporting the field but not the variable: not a problem, + -- as per [Wrinkle: exports] in Note [Record field impedance matching]. + | otherwise + = Just (gre, Nothing) + matching_flds + | isVarOcc missing_occ -- (This only applies to variables.) + = lookupGRE gre_env $ + LookupOccName missing_occ (RelevantGREsFOS WantField) + | otherwise + = [] -- BootFldReexport T18999_NoDisambiguateRecordFields T16745A + + in case mapMaybe mb_ok $ matching_flds of + + -- At least 2 matches: report an ambiguity error. + (gre1,_):(gre2,_):gres_ids -> do + addErrAt (nameSrcSpan missing_name) $ + mkNameClashErr gre_env (nameRdrName missing_name) + (gre1 NE.:| gre2 : map fst gres_ids) + return Nothing + + -- Single match: resolve the issue. + [(_,mb_fld_id)] -> + -- See Note [Record field impedance matching]. + for mb_fld_id $ \ fld_id -> do + let local_boot_var = + Id.mkExportedVanillaId missing_name (idType fld_id) + return (local_boot_var, fld_id) + + -- Otherwise: report that the hs file does not export something + -- that the hs-boot file exports. + [] -> do + addErrAt (nameSrcSpan missing_name) + (missingBootThing HsBoot missing_name MissingBootExport) + return Nothing + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing + = return Nothing + + -- Check that the actual module also defines the thing, and + -- then compare the definitions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = do checkBootDeclM HsBoot boot_thing real_thing + return Nothing + + | otherwise + = do addErrTc (missingBootThing HsBoot name MissingBootDefinition) + return Nothing + where + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail + `minusList` availNames avail + + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + + check_cls_inst :: DFunId -> TcM (Maybe (Id,Id)) + -- Returns a pair of the boot dfun in terms of the equivalent + -- real dfun. Delicate (like checkBootDecl) because it depends + -- on the types lining up precisely even to the ordering of + -- the type variables in the foralls. + check_cls_inst boot_dfun + | (real_dfun : _) <- find_real_dfun boot_dfun + , let dfun_name = idName boot_dfun + local_boot_dfun = Id.mkExportedVanillaId dfun_name (idType real_dfun) + = return $ Just (local_boot_dfun, real_dfun) + -- Two tricky points here: + -- + -- * The local_boot_fun should have a Name from the /boot-file/, + -- but type from the dfun defined in /this module/. + -- That ensures that the TyCon etc inside the type are + -- the ones defined in this module, not the ones gotten + -- from the hi-boot file, which may have a lot less info + -- (#8743, comment:10). + -- + -- * The DFunIds from boot_details are /GlobalIds/, because + -- they come from typechecking M.hi-boot. + -- But all bindings in this module should be for /LocalIds/, + -- otherwise dependency analysis fails (#16038). This + -- is another reason for using mkExportedVanillaId, rather + -- that modifying boot_dfun, to make local_boot_fun. + -- + -- See Note [DFun impedance matching]. + + | otherwise + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ + do { traceTc "check_cls_inst" $ vcat + [ text "local_insts" <+> + vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] + + ; addErrTc $ TcRnBootMismatch HsBoot + $ MissingBootInstance boot_dfun + ; return Nothing } + + find_real_dfun :: DFunId -> [DFunId] + find_real_dfun boot_dfun + = [dfun | inst <- local_insts + , let dfun = instanceDFunId inst + , idType dfun `eqType` boot_dfun_ty ] + where + boot_dfun_ty = idType boot_dfun + + +-- In general, to perform these checks we have to +-- compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: HsBootOrSig + -> TyThing -- ^ boot thing + -> TyThing -- ^ real thing + -> TcM () +checkBootDeclM boot_or_sig boot_thing real_thing + = for_ boot_errs $ \ boot_err -> + addErrAt span $ + TcRnBootMismatch boot_or_sig $ + BootMismatch boot_thing real_thing boot_err + where + boot_errs = execWriter $ checkBootDecl boot_or_sig boot_thing real_thing + + -- Here we use the span of the boot thing or, if it doesn't have a sensible + -- span, that of the real thing, + span + | let span = nameSrcSpan (getName boot_thing) + , isGoodSrcSpan span + = span + | otherwise + = nameSrcSpan (getName real_thing) + +-- | Writer monad for accumulating errors when comparing an hs-boot or +-- signature file with its implementing module. +type BootErrsM err = Writer [err] () + +-- | If the test in the first parameter is True, succeed. +-- Otherwise, record the given error. +check :: Bool -> err -> BootErrsM err +check True _ = checkSuccess +check False err = bootErr err + +-- | Record an error. +bootErr :: err -> BootErrsM err +bootErr err = tell [err] + +-- | A convenience synonym for a lack of errors, for @checkBootDecl@ and friends. +checkSuccess :: BootErrsM err +checkSuccess = return () + +-- | Map over the error types in an error-accumulating computation. +embedErrs :: (err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +embedErrs f = mapWriter (second (fmap f)) + +-- | Wrap up a list of errors into a single message. +wrapErrs :: (NE.NonEmpty err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +wrapErrs f w = + case execWriter w of + [] -> checkSuccess + err : errs -> bootErr (f $ err :| errs) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: HsBootOrSig -> TyThing -> TyThing -> BootErrsM BootMismatchWhat + +checkBootDecl _ (AnId id1) (AnId id2) + = assert (id1 == id2) $ + check (idType id1 `eqType` idType id2) + (BootMismatchedIdTypes id1 id2) + +checkBootDecl boot_or_sig (ATyCon tc1) (ATyCon tc2) + = wrapErrs (BootMismatchedTyCons tc1 tc2) $ + checkBootTyCon boot_or_sig tc1 tc2 + +checkBootDecl _ t1 t2 + = pprPanic "checkBootDecl" (ppr t1 $$ ppr t2) + +-- | Run the check provided for every pair of elements in the lists. +-- +-- Records an error: +-- +-- - when any two items at the same position in the two lists don't match +-- according to the given function, +-- - when the lists are of different lengths. +checkListBy :: (a -> a -> BootErrsM err) -> [a] -> [a] + -> (BootListMismatches a err -> err2) + -> BootErrsM err2 +checkListBy check_fun as bs mk_err = wrapErrs mk_err $ go 1 as bs + where + go _ [] [] = checkSuccess + go !i (x:xs) (y:ys) = + do { embedErrs (MismatchedThing i x y) $ check_fun x y + ; go (i+1) xs ys } + go _ _ _ = bootErr MismatchedLength + +---------------- +checkBootTyCon :: HsBootOrSig -> TyCon -> TyCon -> BootErrsM BootTyConMismatch +checkBootTyCon boot_or_sig tc1 tc2 + | not (eqType (tyConKind tc1) (tyConKind tc2)) + -- First off, check the kind + = bootErr TyConKindMismatch + + | Just c1 <- tyConClass_maybe tc1 + , Just c2 <- tyConClass_maybe tc2 + , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + = classExtraBigSig c2 + , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + = do { check_roles + ; embedErrs (TyConMismatchedClasses c1 c2) $ + do { -- Checks kind of class + ; check (liftEq (eqFD env) clas_fds1 clas_fds2) + MismatchedFunDeps + ; unless (isAbstractTyCon tc1) $ + do { check (liftEq (eqTypeX env) sc_theta1 sc_theta2) + MismatchedSuperclasses + ; checkListBy (compatClassOp env boot_or_sig) op_stuff1 op_stuff2 + MismatchedMethods + ; checkListBy (compatAT env boot_or_sig) ats1 ats2 + MismatchedATs + ; check (classMinimalDef c1 `BF.implies` classMinimalDef c2) + MismatchedMinimalPragmas + } } } + + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = assert (tc1 == tc2) $ + do { check_roles + ; check (eqTypeX env syn_rhs1 syn_rhs2) $ + TyConSynonymMismatch syn_rhs1 syn_rhs2 } + + -- This allows abstract 'data T a' to be implemented using 'type T = ...' + -- and abstract 'class K a' to be implement using 'type K = ...' + -- See Note [Synonyms implement abstract data] + | Hsig <- boot_or_sig -- don't support for hs-boot yet + , isAbstractTyCon tc1 + , Just (tvs, ty) <- synTyConDefn_maybe tc2 + = checkSynAbsData tc1 tc2 tvs ty + + | Just fam_flav1 <- famTyConFlav_maybe tc1 + , Just fam_flav2 <- famTyConFlav_maybe tc2 + = assert (tc1 == tc2) $ + do { let injInfo1 = tyConInjectivityInfo tc1 + injInfo2 = tyConInjectivityInfo tc2 + ; -- check equality of roles, family flavours and injectivity annotations + -- (NB: Type family roles are always nominal. But the check is + -- harmless enough.) + ; check_roles + ; compatFamFlav fam_flav1 fam_flav2 + ; check (injInfo1 == injInfo2) TyConInjectivityMismatch } + + | isAlgTyCon tc1 && isAlgTyCon tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = assert (tc1 == tc2) $ + do { check_roles + ; let rhs1 = algTyConRhs tc1 + rhs2 = algTyConRhs tc2 + ; embedErrs (TyConMismatchedData rhs1 rhs2) $ + do { check (liftEq (eqTypeX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + MismatchedDatatypeContexts + ; compatAlgRhs rhs1 rhs2 } } + + | otherwise = bootErr TyConsVeryDifferent + -- two very different types; + -- should be obvious to the user what the problem is + where + check_roles = checkRoles boot_or_sig tc1 (tyConRoles tc2) + + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +-- | Check that two class methods have compatible type signatures. +compatClassOp :: RnEnv2 -> HsBootOrSig -> ClassOpItem -> ClassOpItem -> BootErrsM BootMethodMismatch +compatClassOp env boot_or_sig (id1, def_meth1) (id2, def_meth2) + = do { check (name1 == name2) $ + MismatchedMethodNames + ; check (eqTypeX env op_ty1 op_ty2) $ + MismatchedMethodTypes op_ty1 op_ty2 + ; case boot_or_sig of + HsBoot -> + check (liftEq eqDM def_meth1 def_meth2) $ + MismatchedDefaultMethods False + Hsig -> + check (subDM op_ty1 def_meth1 def_meth2) $ + MismatchedDefaultMethods True } + where + name1 = idName id1 + name2 = idName id2 + op_ty1 = classMethodTy id1 + op_ty2 = classMethodTy id2 + + eqDM (_, VanillaDM) (_, VanillaDM) = True + eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 + eqDM _ _ = False + + -- NB: first argument is from hsig, second is from real impl. + -- Order of pattern matching matters. + subDM _ Nothing _ = True + subDM _ _ Nothing = False + + -- If the hsig wrote: + -- + -- f :: a -> a + -- default f :: a -> a + -- + -- this should be validly implementable using an old-fashioned + -- vanilla default method. + subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) + = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come + -- from tc1, so use eqType, and /not/ eqTypeX + + -- This case can occur when merging signatures + subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + + subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True + subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + +-- | Check that two associated types are compatible. +compatAT :: RnEnv2 -> HsBootOrSig -> ClassATItem -> ClassATItem + -> BootErrsM BootATMismatch +compatAT env boot_or_sig (ATI tc1 def_ats1) (ATI tc2 def_ats2) + = do { embedErrs MismatchedTyConAT $ + checkBootTyCon boot_or_sig tc1 tc2 + ; check (compatATDef def_ats1 def_ats2) + MismatchedATDefaultType } + + where + -- Ignore the location of the defaults + compatATDef Nothing Nothing = True + compatATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 + compatATDef _ _ = False + +-- | Check that two functional dependencies are the same. +eqFD :: RnEnv2 -> FunDep TyVar -> FunDep TyVar -> Bool +eqFD env (as1,bs1) (as2,bs2) = + liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + +-- | Check compatibility of two type family flavours. +compatFamFlav :: FamTyConFlav -> FamTyConFlav -> BootErrsM BootTyConMismatch +compatFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon + = checkSuccess +compatFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) + = checkSuccess +compatFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon + = checkSuccess -- This case only happens for hsig merging. +compatFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 +compatFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) + = checkSuccess +compatFamFlav flav1 flav2 + = bootErr $ TyConFlavourMismatch flav1 flav2 + +-- | Check that two 'AlgTyConRhs's are compatible. +compatAlgRhs :: AlgTyConRhs -> AlgTyConRhs -> BootErrsM BootDataMismatch +compatAlgRhs (AbstractTyCon {}) _rhs2 = + checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon +compatAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy compatCon (data_cons tc1) (data_cons tc2) MismatchedConstructors +compatAlgRhs tc1@NewTyCon{ data_con = dc1 } tc2@NewTyCon{ data_con = dc2 } = + embedErrs (MismatchedConstructors . NE.singleton . MismatchedThing 1 dc1 dc2) $ + compatCon (data_con tc1) (data_con tc2) +compatAlgRhs _ _ = bootErr MismatchedNewtypeVsData + +-- | Check that two 'DataCon's are compatible. +compatCon :: DataCon -> DataCon -> BootErrsM BootDataConMismatch +compatCon c1 c2 + = do { check (dataConName c1 == dataConName c2) + MismatchedDataConNames + ; check (dataConIsInfix c1 == dataConIsInfix c2) + MismatchedDataConFixities + ; check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + MismatchedDataConBangs + ; check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) + MismatchedDataConFieldLabels + ; check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) + MismatchedDataConTypes } + +eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br1) + -> BootErrsM BootTyConMismatch +eqClosedFamilyAx Nothing Nothing = checkSuccess +eqClosedFamilyAx Nothing (Just _) = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just _) Nothing = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) + (Just (CoAxiom { co_ax_branches = branches2 })) + = checkListBy eqClosedFamilyBranch branch_list1 branch_list2 + TyConAxiomMismatch + where + branch_list1 = fromBranches branches1 + branch_list2 = fromBranches branches2 + +eqClosedFamilyBranch :: CoAxBranch -> CoAxBranch -> BootErrsM BootAxiomBranchMismatch +eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 + , cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 + , cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 + , Just env <- eqVarBndrs env1 cvs1 cvs2 + = do { check (liftEq (eqTypeX env) lhs1 lhs2) MismatchedAxiomLHS + ; check (eqTypeX env rhs1 rhs2) MismatchedAxiomRHS } + | otherwise + = bootErr MismatchedAxiomBinders + +{- Note [Role subtyping] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the current formulation of roles, role subtyping is only OK if the +"abstract" TyCon was not representationally injective. Among the most +notable examples of non representationally injective TyCons are abstract +data, which can be implemented via newtypes (which are not +representationally injective). The key example is +in this example from #13140: + + -- In an hsig file + data T a -- abstract! + type role T nominal + + -- Elsewhere + foo :: Coercible (T a) (T b) => a -> b + foo x = x + +We must NOT allow foo to typecheck, because if we instantiate +T with a concrete data type with a phantom role would cause +Coercible (T a) (T b) to be provable. Fortunately, if T is not +representationally injective, we cannot make the inference that a ~N b if +T a ~R T b. + +Unconditional role subtyping would be possible if we setup +an extra set of roles saying when we can project out coercions +(we call these proj-roles); then it would NOT be valid to instantiate T +with a data type at phantom since the proj-role subtyping check +would fail. See #13140 for more details. + +One consequence of this is we get no role subtyping for non-abstract +data types in signatures. Suppose you have: + + signature A where + type role T nominal + data T a = MkT + +If you write this, we'll treat T as injective, and make inferences +like T a ~R T b ==> a ~N b (mkSelCo). But if we can +subsequently replace T with one at phantom role, we would then be able to +infer things like T Int ~R T Bool which is bad news. + +We could allow role subtyping here if we didn't treat *any* data types +defined in signatures as injective. But this would be a bit surprising, +replacing a data type in a module with one in a signature could cause +your code to stop typechecking (whereas if you made the type abstract, +it is more understandable that the type checker knows less). + +It would have been best if this was purely a question of defaults +(i.e., a user could explicitly ask for one behavior or another) but +the current role system isn't expressive enough to do this. +Having explicit proj-roles would solve this problem. +-} + +checkRoles :: HsBootOrSig -> TyCon -> [Role] -> BootErrsM BootTyConMismatch +checkRoles boot_or_sig tc1 r2 + | boot_or_sig == HsBoot + || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] + = check (r1 == r2) (TyConRoleMismatch False) + | otherwise + = check (r2 `rolesSubtypeOf` r1) (TyConRoleMismatch True) + where + + r1 = tyConRoles tc1 + + rolesSubtypeOf [] [] = True + -- NB: this relation is the OPPOSITE of the subroling relation + rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys + rolesSubtypeOf _ _ = False + +{- Note [Synonyms implement abstract data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An abstract data type or class can be implemented using a type synonym, +but ONLY if: + + 1. T, as a standalone occurrence, is a valid type + (T is "curryable"), and + + 2. T is valid in an instance head. + +This gives rise to the following conditions under which we can implement +an abstract data declaration @data T@ using a type synonym @type T tvs = rhs@: + + 1. The type synonym T is nullary (tvs is null). + + 2. The rhs must not contain any foralls, quantified types, or type family + applications. + See 'invalidAbsDataSubTypes' which computes a collection of + invalid subtypes. + +See also 'HowAbstract' and Note [Skolem abstract data]. +-} + +-- | We are implementing an abstract data declaration of the form @data T@ +-- in a signature file, with a type synonym @type T tvs = rhs@ in the +-- implementing module. +-- +-- This function checks that the implementation is valid: +-- +-- 1. the type synonym T is nullary, i.e. tvs is null, +-- 2. rhs doesn't contain any type families, foralls, or qualified types. +-- +-- See Note [Synonyms implement abstract data] +checkSynAbsData :: TyCon -- ^ @tc1@, the abstract data 'TyCon' we are implementing + -> TyCon -- ^ @tc2@, a type synonym @type T tvs = ty@ + -- we are using to implement @tc1@ + -> [TyVar] -- ^ @tvs@ + -> Type -- ^ @ty@ + -> BootErrsM BootTyConMismatch +checkSynAbsData tc1 tc2 syn_tvs syn_rhs + -- We are implementing @data T@ with @type T tvs = rhs@. + -- Check the conditions of Note [Synonyms implement abstract data]. + = do { -- (1): T is nullary. + ; check (null syn_tvs) $ + SynAbstractData SynAbsDataTySynNotNullary + -- (2): the RHS of the type synonym is valid. + ; case invalidAbsDataSubTypes syn_rhs of + [] -> checkSuccess + err:errs -> bootErr $ SynAbstractData $ + SynAbstractDataInvalidRHS (err :| errs) + -- NB: this allows implementing e.g. @data T :: Nat@ with @type T = 3@. + -- See #15138. + + -- TODO: When it's a synonym implementing a class, we really + -- should check that the fundeps are satisfied, but + -- there is not an obvious way to do this for a constraint synonym. + -- So for now, let it all through (it won't cause segfaults, anyway). + -- Tracked at #12704. + + -- ... we also need to check roles. + ; if | Just (tc2', args) <- tcSplitTyConApp_maybe syn_rhs + , null syn_tvs -- Don't report role errors unless the type synonym is nullary + -> assert (null (tyConRoles tc2)) $ + -- If we have something like: + -- + -- signature H where + -- data T a + -- module H where + -- data K a b = ... + -- type T = K Int + -- + -- we need to drop the first role of K when comparing! + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2')) + | otherwise + -> checkSuccess + } + +{- + -- Hypothetically, if we were allow to non-nullary type synonyms, here + -- is how you would check the roles + if length tvs == length roles1 + then checkRoles roles1 roles2 + else case tcSplitTyConApp_maybe ty of + Just (tc2', args) -> + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2') ++ roles2) + Nothing -> Just roles_msg +-} + +-- | Is this type a valid implementation of abstract data? +-- +-- Returns a list of invalid sub-types encountered. +invalidAbsDataSubTypes :: Type -> [Type] +invalidAbsDataSubTypes = execWriter . go + where + go :: Type -> Writer [Type] () + go ty + | Just ty' <- coreView ty + = go ty' + go TyVarTy{} + = ok -- We report an error at the binding site of type variables, + -- e.g. in the TySyn LHS or in the forall. + -- It's not useful to report a second error for their occurrences + go (AppTy t1 t2) + = do { go t1; go t2 } + go ty@(TyConApp tc tys) + | isTypeFamilyTyCon tc + = invalid ty + | otherwise + = mapM_ go tys + go ty@(ForAllTy{}) + = invalid ty + go ty@(FunTy af w t1 t2) + | af == FTF_T_T + = do { go w + ; go (typeKind t1) ; go t1 + ; go (typeKind t2) ; go t2 + } + | otherwise + = invalid ty + go LitTy{} + = ok + go ty@(CastTy{}) + = invalid ty + go ty@(CoercionTy{}) + = invalid ty + + ok = pure () + invalid ty = tell [ty] + +{- +************************************************************************ +* * + Type-checking the top level of a module (continued) +* * +************************************************************************ +-} + +rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) +-- Fails if there are any errors +rnTopSrcDecls group + = do { -- Rename the source decls + traceRn "rn12" empty ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; + traceRn "rn13" empty ; + (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; + traceRn "rn13-plugin" empty ; + + -- save the renamed syntax, if we want it + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; + + -- Dump trace of renaming part + rnDump rn_decls ; + return (tcg_env', rn_decls) + } + +tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_valds = hs_val_binds@(XValBindsLR + (NValBinds val_binds val_sigs)) }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + -- Source-language instances, including derivings, + -- and import the supporting declarations + traceTc "Tc3" empty ; + (tcg_env, inst_infos, th_bndrs, + XValBindsLR (NValBinds deriv_binds deriv_sigs)) + <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; + + updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ + setGblEnv tcg_env $ do { + + -- Foreign import declarations next. + traceTc "Tc4" empty ; + (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { + + -- Default declarations + traceTc "Tc4a" empty ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Value declarations next. + -- It is important that we check the top-level value bindings + -- before the GHC-generated derived bindings, since the latter + -- may be defined in terms of the former. (For instance, + -- the bindings produced in a Data instance.) + traceTc "Tc5" empty ; + tc_envs <- tcTopBinds val_binds val_sigs; + restoreEnvs tc_envs $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs@(tcg_env, tcl_env) + <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; + restoreEnvs tc_envs $ do { -- Environment doesn't change now + + -- Second pass over class and instance declarations, + -- now using the kind-checked decls + traceTc "Tc6" empty ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + + -- Foreign exports + traceTc "Tc7" empty ; + (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; + + -- Annotations + annotations <- tcAnnotations annotation_decls ; + + -- Rules + rules <- tcRules rule_decls ; + + -- Wrap up + traceTc "Tc7a" empty ; + let { all_binds = inst_binds `unionBags` + foe_binds + + ; fo_gres = fi_gres `unionBags` foe_gres + ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` (greName gre)) + emptyFVs fo_gres + + ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) + `minusNameSet` getTypeSigNames val_sigs + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names + , tcg_rules = tcg_rules tcg_env + ++ flattenRuleDecls rules + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + + -- See Note [Newtype constructor usage in foreign declarations] + addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; + + return (tcg_env', tcl_env) + }}}}}} + +tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" + +--------------------------- +tcTyClsInstDecls :: [TyClGroup GhcRn] + -> [LDerivDecl GhcRn] + -> [(RecFlag, LHsBinds GhcRn)] + -> TcM (TcGblEnv, -- The full inst env + [InstInfo GhcRn], -- Source-code instance decls to + -- process; contains all dfuns for + -- this module + ThBindEnv, -- TH binding levels + HsValBinds GhcRn) -- Supporting bindings for derived + -- instances + +tcTyClsInstDecls tycl_decls deriv_decls binds + = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ + tcAddPatSynPlaceholders (getPatSynBinds binds) $ + do { (tcg_env, inst_info, deriv_info, th_bndrs) + <- tcTyAndClassDecls tycl_decls ; + ; setGblEnv tcg_env $ do { + -- With the @TyClDecl@s and @InstDecl@s checked we're ready to + -- process the deriving clauses, including data family deriving + -- clauses discovered in @tcTyAndClassDecls@. + -- + -- Careful to quit now in case there were instance errors, so that + -- the deriving errors don't pile up as well. + ; failIfErrsM + ; (tcg_env', inst_info', val_binds) + <- tcInstDeclsDeriv deriv_info deriv_decls + ; setGblEnv tcg_env' $ do { + failIfErrsM + ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) + }}} + +{- ********************************************************************* +* * + Checking for 'main' +* * +************************************************************************ +-} + +checkMainType :: TcGblEnv -> TcRn WantedConstraints +-- If this is the Main module, and it defines a function main, +-- check that its type is of form IO tau. +-- If not, do nothing +-- See Note [Dealing with main] +checkMainType tcg_env + = do { hsc_env <- getTopEnv + ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) + then return emptyWC else + + do { rdr_env <- getGlobalRdrEnv + ; let dflags = hsc_dflags hsc_env + main_occ = getMainOcc dflags + main_gres = lookupGRE rdr_env (LookupOccName main_occ SameNameSpace) + ; case filter isLocalGRE main_gres of { + [] -> return emptyWC ; + (_:_:_) -> return emptyWC ; + [main_gre] -> + + do { let main_name = greName main_gre + ctxt = FunSigCtxt main_name NoRRC + ; main_id <- tcLookupId main_name + ; (io_ty,_) <- getIOType + ; let main_ty = idType main_id + eq_orig = TypeEqOrigin { uo_actual = main_ty + , uo_expected = io_ty + , uo_thing = Nothing + , uo_visible = True } + ; (_, lie) <- captureTopConstraints $ + setMainCtxt main_name io_ty $ + tcSubTypeSigma eq_orig ctxt main_ty io_ty + ; return lie } } } } + +checkMain :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (LocatedL [LIE GhcPs]) -- Export specs of Main module + -> TcM TcGblEnv +-- If we are in module Main, check that 'main' is exported, +-- and generate the runMainIO binding that calls it +-- See Note [Dealing with main] +checkMain explicit_mod_hdr export_ies + = do { hsc_env <- getTopEnv + ; tcg_env <- getGblEnv + + ; let dflags = hsc_dflags hsc_env + main_mod = mainModIs (hsc_HUE hsc_env) + main_occ = getMainOcc dflags + + exported_mains :: [Name] + -- Exported things that are called 'main' + exported_mains = [ name | avail <- tcg_exports tcg_env + , name <- availNames avail + , nameOccName name == main_occ ] + + ; if | tcg_mod tcg_env /= main_mod + -> -- Not the main module + return tcg_env + + | [main_name] <- exported_mains + -> -- The module indeed exports a function called 'main' + generateMainBinding tcg_env main_name + + | otherwise + -> assert (null exported_mains) $ + -- A fully-checked export list can't contain more + -- than one function with the same OccName + do { complain_no_main dflags main_mod main_occ + ; return tcg_env } } + where + complain_no_main dflags main_mod main_occ + = unless (interactive && not explicit_mod_hdr) $ + addErrTc (noMainMsg main_mod main_occ) -- #12906 + where + interactive = ghcLink dflags == LinkInMemory + -- Without an explicit module header... + -- in interactive mode, don't worry about the absence of 'main'. + -- in other modes, add error message and go on with typechecking. + + noMainMsg main_mod main_occ + = TcRnMissingMain explicit_export_list main_mod main_occ + explicit_export_list = explicit_mod_hdr && isJust export_ies + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainOcc :: DynFlags -> OccName +getMainOcc dflags = case mainFunIs dflags of + Just fn -> mkVarOccFS (mkFastString fn) + Nothing -> mkVarOccFS (fsLit "main") + +generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv +-- There is a single exported 'main' function, called 'foo' (say), +-- which may be locally defined or imported +-- Define and typecheck the binding +-- :Main.main :: IO res_ty = runMainIO res_ty foo +-- This wraps the user's main function in the top-level stuff +-- defined in runMainIO (eg catching otherwise un-caught exceptions) +-- See Note [Dealing with main] +generateMainBinding tcg_env main_name = do + { traceTc "checkMain found" (ppr main_name) + ; (io_ty, res_ty) <- getIOType + ; let loc = getSrcSpan main_name + main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name)) + ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ + tcCheckMonoExpr main_expr_rn io_ty + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty + ; co = mkWpTyApps [res_ty] + -- The ev_binds of the `main` function may contain deferred + -- type errors when type of `main` is not `IO a`. The `ev_binds` + -- must be put inside `runMainIO` to ensure the deferred type + -- error can be emitted correctly. See #13838. + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ + mkHsDictLet ev_binds main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name + , tcg_binds = tcg_binds tcg_env + `snocBag` main_bind + , tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) }) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + } + +getIOType :: TcM (TcType, TcType) +-- Return (IO alpha, alpha) for fresh alpha +getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; return (mkTyConApp ioTyCon [res_ty], res_ty) } + +setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) +setMainCtxt main_name io_ty thing_inside + = setSrcSpan (getSrcSpan main_name) $ + addErrCtxt main_ctxt $ + checkConstraints skol_info [] [] $ -- Builds an implication if necessary + thing_inside -- e.g. with -fdefer-type-errors + where + skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty [] + main_ctxt = text "When checking the type of the" + <+> ppMainFn (nameOccName main_name) + +{- Note [Dealing with main] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with the 'main' declaration is surprisingly tricky. Here are +the moving parts: + +* The flag -main-is=M.foo allows you to set the main module to 'M', + and the main function to 'foo'. We access them through + mainModIs :: HscEnv -> Module -- returns M + getMainOcc :: DynFlags -> OccName -- returns foo + Of course usually M = Main, and foo = main. + +* checkMainType: when typechecking module M, we add an extra check that + foo :: IO tau, for some type tau. + This avoids getting ambiguous-type errors from the monomorphism restriction + applying to things like + main = return () + Note that checkMainType does not consult the export list because + we have not yet done rnExports (and can't do it until later). + +* rnExports: checks the export list. Very annoyingly, we can only do + this after running any finalisers, which may add new declarations. + That's why checkMainType and checkMain have to be separate. + +* checkMain: does two things: + - check that the export list does indeed export something called 'foo' + - generateMainBinding: generate the root-main binding + :Main.main = runMainIO M.foo + See Note [Root-main Id] + +An annoying consequence of having both checkMainType and checkMain is +that, when (but only when) -fdefer-type-errors is on, we may report an +ill-typed 'main' twice (as warnings): once in checkMainType and once +in checkMain. See test typecheck/should_fail/T13292. + +We have the following tests to check this processing: +----------------+----------------------------------------------------------------------------------+ + | Module Header: | + +-------------+-------------+-------------+-------------+-------------+------------+ + | module | module Main | | module Main |module |module Main | + | Main(main) | | | (module X)| Main () | (Sub.main)| +----------------+==================================================================================+ +`main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main | +in Main module | Ambiguous | | Ambiguous | | `main` not | | +and in imported | | | | | exported | | +module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 | + | | | | X = Main | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main | +only in imported| | No `main` in| | | `main` not | | +submodule Sub. | | `Main` | | | exported | | + | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 | + | | | | X = Sub | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo | +in submodule | | No `foo` in | | | `foo` not | | +Sub. | | `Main` | | | exported | | +GHC option: | | | | | | | + -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 | + | Remark 1) | | | X = Sub | | Remark 3) | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ + +Remarks: +* The first line shows the exported `main` function or the error. +* The second line shows the coresponding test case. +* The module `Sub` contains the following functions: + main :: IO () + foo :: IO () +* Remark 1) Here the header is `Main (foo)`. +* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`. +* Remark 3) Here the header is `Main (Sub.foo)`. + + +Note [Root-main Id] +~~~~~~~~~~~~~~~~~~~ +The function that the RTS invokes is always :Main.main, which we call +root_main_id. (Because GHC allows the user to have a module not +called Main as the main module, we can't rely on the main function +being called "Main.main". That's why root_main_id has a fixed module +":Main".) + +This is unusual: it's a LocalId whose Name has a Module from another +module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we +get two defns for 'main' in the interface file! + +When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file. +When the interface is read back in we have to add a special case when creating the +Id because otherwise we would go looking for the :Main module which obviously doesn't +exist. For this logic see GHC.IfaceToCore.mk_top_id. + +There is also some similar (probably dead) logic in GHC.Rename.Env which says it +was added for External Core which faced a similar issue. + + +********************************************************* +* * + GHCi stuff +* * +********************************************************* +-} + +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) +-- Initialise the tcg_inst_env with instances from all home modules. +-- This mimics the more selective call to hptInstances in tcRnImports +runTcInteractive hsc_env thing_inside + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ + do { traceTc "setInteractiveContext" $ + vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) + , text "icReaderEnv (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) + , let local_gres = filter isLocalGRE gres + , not (null local_gres) ]) ] + + ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface + : dep_orphs (mi_deps iface)) + (loadSrcInterface (text "runTcInteractive") m + NotBoot mb_pkg) + + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> + case i of -- force above: see #15111 + IIModule n -> getOrphans n NoPkgQual + IIDecl i -> getOrphans (unLoc (ideclName i)) + (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) + + ; let imports = emptyImportAvails { imp_orphs = orphs } + + upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') + + where + gbl_env' = gbl_env + { tcg_rdr_env = icReaderEnv icxt + , tcg_type_env = type_env + , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_fix_env = ic_fix_env icxt + , tcg_default = ic_default icxt + -- must calculate imp_orphs of the ImportAvails + -- so that instance visibility is done correctly + , tcg_imports = imports } + + lcl_env' = modifyLclCtxt (tcExtendLocalTypeEnv lcl_ids) lcl_env + + ; updEnvs upd_envs thing_inside } + where + (home_insts, home_fam_insts) = hptAllInstances hsc_env + + icxt = hsc_IC hsc_env + (ic_insts, ic_finsts) = ic_instances icxt + (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) + + is_closed :: TyThing -> Either (Name, TcTyThing) TyThing + -- Put Ids with free type variables (always RuntimeUnks) + -- in the *local* type environment + -- See Note [Initialising the type environment for GHCi] + is_closed thing + | AnId id <- thing + , not (isTypeClosedLetBndr id) + = Left (idName id, ATcId { tct_id = id + , tct_info = NotLetBound }) + | otherwise + = Right thing + + type_env1 = mkTypeEnvWithImplicits top_ty_things + type_env = extendTypeEnvWithIds type_env1 + $ map instanceDFunId (instEnvElts ic_insts) + -- Putting the dfuns in the type_env + -- is just to keep Core Lint happy + +{- Note [Initialising the type environment for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the Ids in ic_things, defined by the user in 'let' stmts, +have closed types. E.g. + ghci> let foo x y = x && not y + +However the GHCi debugger creates top-level bindings for Ids whose +types have free RuntimeUnk skolem variables, standing for unknown +types. If we don't register these free TyVars as global TyVars then +the typechecker will try to quantify over them and fall over in +skolemiseQuantifiedTyVar. so we must add any free TyVars to the +typechecker's global TyVar set. That is done by using +tcExtendLocalTypeEnv. + +We do this by splitting out the Ids with open types, using 'is_closed' +to do the partition. The top-level things go in the global TypeEnv; +the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the +local TypeEnv. + +Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope +things are already in the interactive context's GlobalRdrEnv. +Extending the local RdrEnv isn't terrible, but it means there is an +entry for the same Name in both global and local RdrEnvs, and that +lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). + +We don't bother with the tcl_th_bndrs environment either. +-} + +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ Any ], a list of the bound +-- values, coerced to Any. +tcRnStmt :: HscEnv -> GhciLStmt GhcPs + -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) +tcRnStmt hsc_env rdr_stmt + = runTcInteractive hsc_env $ do { + + -- The real work is done here + ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; + zonked_expr <- zonkTopLExpr tc_expr ; + zonked_ids <- zonkTopBndrs bound_ids ; + + failIfErrsM ; -- we can't do the next step if there are + -- representation polymorphism errors + -- test case: ghci/scripts/T13202{,a} + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mapM_ (addErr . TcRnGhciUnliftedBind) $ + filter (mightBeUnliftedType . idType) zonked_ids ; + + traceTc "tcs 1" empty ; + this_mod <- getModule ; + global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; + -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env + + traceOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; + + return (global_ids, zonked_expr, fix_env) + } + +{- +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + +Here is the grand plan, implemented in tcUserStmt + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + + expr (of non-IO type, + result not showable) ==> error +-} + +-- | A plan is an attempt to lift some code into the IO monad. +type PlanResult = ([Id], LHsExpr GhcTc) +type Plan = TcM PlanResult + +-- | Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans :: NonEmpty Plan -> Plan +runPlans = foldr1 (flip tryTcDiscardingErrs) + +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environment'. +-- +-- By 'lift' and 'environment we mean that the code is changed to +-- execute properly in an IO monad. See Note [Interactively-bound Ids +-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying +-- different ways ('plans') of lifting the code into the IO monad and +-- type checking each plan until one succeeds. +tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (BodyStmt _ expr _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + + ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell + (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr) + -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO + ; uniq <- newUnique + ; let loc' = noAnnSrcSpan $ locA loc + ; interPrintName <- getInteractivePrintName + ; let fresh_it = itName uniq (locA loc) + matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr + emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind FromSource + (L loc' fresh_it) matches) + { fun_ext = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + -- [let it = expr] + let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn + $ XValBindsLR + (NValBinds [(NonRecursive,unitBag the_bind)] []) + + -- [it <- e] + bind_stmt = L loc $ BindStmt + (XBindStmtRn + { xbsrn_bindOp = mkRnSyntaxExpr bindIOName + , xbsrn_failOp = Nothing + }) + (L loc (VarPat noExtField (L loc' fresh_it))) + (nlHsApp ghciStep rn_expr) + + -- [; print it] + print_it = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) + (nlHsVar fresh_it)) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- NewA + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName + [rn_expr , nlHsVar interPrintName]) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_b = L loc $ BodyStmt noExtField (rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_c = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- See Note [GHCi Plans] + + it_plans = + -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- liftZonkM $ zonkTcType (idType it_id) + ; when (isUnitTy it_ty) failM + ; return stuff } :| + + -- Plan B; a naked bind statement + [ tcGhciStmts [bind_stmt] + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } ] + + -- Plans where we don't bind "it" + no_it_plans = + tcGhciStmts [no_it_a] :| + tcGhciStmts [no_it_b] : + tcGhciStmts [no_it_c] : + [] + + ; generate_it <- goptM Opt_NoIt + + -- We disable `-fdefer-type-errors` in GHCi for naked expressions. + -- See Note [Deferred type errors in GHCi] + + -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` + -- and `-fdefer-out-of-scope-variables`. However the flag + -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and + -- `-fno-defer-out-of-scope-variables`. Thus the later two flags + -- also need to be unset here. + ; plan <- unsetGOptM Opt_DeferTypeErrors $ + unsetGOptM Opt_DeferTypedHoles $ + unsetGOptM Opt_DeferOutOfScopeVariables $ + runPlans $ if generate_it + then no_it_plans + else it_plans + + ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell + (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan) + + ; fix_env <- getFixityEnv + ; return (plan, fix_env) } + +{- Note [Deferred type errors in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHCi, we ensure that type errors don't get deferred when type checking the +naked expressions. Deferring type errors here is unhelpful because the +expression gets evaluated right away anyway. It also would potentially emit +two redundant type-error warnings, one from each plan. + +#14963 reveals another bug that when deferred type errors is enabled +in GHCi, any reference of imported/loaded variables (directly or indirectly) +in interactively issued naked expressions will cause ghc panic. See more +detailed discussion in #14963. + +The interactively issued declarations, statements, as well as the modules +loaded into GHCi, are not affected. That means, for declaration, you could +have + + Prelude> :set -fdefer-type-errors + Prelude> x :: IO (); x = putStrLn True + :14:26: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True + +But for naked expressions, you will have + + Prelude> :set -fdefer-type-errors + Prelude> putStrLn True + :2:10: error: + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘it’: it = putStrLn True + + Prelude> let x = putStrLn True + :2:18: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True +-} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ + rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do + fix_env <- getFixityEnv + return (fix_env, emptyFVs) + -- Don't try to typecheck if the renamer fails! + ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump rn_stmt ; + + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt x pat expr)) <- rn_stmt + = L loc $ BindStmt x pat (nlHsApp ghciStep expr) + | otherwise = rn_stmt + + ; opt_pr_flag <- goptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder + = Just $ mk_print_result_plan gi_stmt v + | otherwise = Nothing + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt] + ; return (plan, fix_env) } + where + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- liftZonkM $ zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + (nlHsVar v)) + (mkRnSyntaxExpr thenIOName) noSyntaxExpr + +{- +Note [GHCi Plans] +~~~~~~~~~~~~~~~~~ +When a user types an expression in the repl we try to print it in three different +ways. Also, depending on whether -fno-it is set, we bind a variable called `it` +which can be used to refer to the result of the expression subsequently in the repl. + +The normal plans are : + A. [it <- e; print e] but not if it::() + B. [it <- e] + C. [let it = e; print it] + +When -fno-it is set, the plans are: + A. [e >>= print] + B. [e] + C. [let it = e in print it] + +The reason for -fno-it is explained in #14336. `it` can lead to the repl +leaking memory as it is repeatedly queried. +-} + +any_lifted :: Type +any_lifted = anyTypeOfKind liftedTypeKind + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [Any]'. +tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult +tcGhciStmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName + ; ret_id <- tcLookupId returnIOName -- return @ IO + ; let ret_ty = mkListTy any_lifted + io_ret_ty = mkTyConApp ioTyCon [ret_ty] + tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts + (mkCheckExpType io_ret_ty) + names = collectLStmtsBinders CollNoDictBinders stmts + + -- OK, we're ready to typecheck the stmts + ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty + ; ((tc_stmts, ids), lie) <- captureTopConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty + ; const_binds <- checkNoErrs (simplifyInteractive lie) + -- checkNoErrs ensures that the plan fails if context redn fails + + + ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty + + -- ret_expr is the expression + -- returnIO @[Any] [unsafeCoerce# @Any x, .., unsafeCoerce# @Any z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type Any. If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + -- + -- We use Any rather than a dummy type such as () because of + -- the rules of unsafeCoerce#; see Unsafe/Coerce.hs for the details. + + ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName + -- We use unsafeCoerce# here because of (U11) in + -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + + ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ + noLocA $ ExplicitList any_lifted $ + map mk_item ids + + mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) + , getRuntimeRep any_lifted + , idType id, any_lifted] + `nlHsApp` nlHsVar id + stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] + + ; return (ids, mkHsDictLet (EvBinds const_binds) $ + noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) + } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr GhcRn) +getGhciStepIO = do + ghciTy <- getGHCiMonad + a_tv <- newName (mkTyVarOccFS (fsLit "a")) + let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) + ioM = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv) + + step_ty :: LHsSigType GhcRn + step_ty = noLocA $ HsSig + { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} + , sig_ext = noExtField + , sig_body = nlHsFunTy ghciM ioM } + + stepTy :: LHsSigWcType GhcRn + stepTy = mkEmptyWildCardBndrs step_ty + + return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + +isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) +isGHCiMonad hsc_env ty + = runTcInteractive hsc_env $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = greName n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = mkTyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + _ -> failWithTc $ TcRnGhciMonadLookupFail ty occIO + +-- | How should we infer a type? See Note [TcRnExprMode] +data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) + | TM_Default -- ^ Instantiate all quantifiers, + -- and do eager defaulting (:type +d) + +-- | tcRnExpr just finds the type of an expression +-- for :type +tcRnExpr :: HscEnv + -> TcRnExprMode + -> LHsExpr GhcPs + -> IO (Messages TcRnMessage, Maybe Type) +tcRnExpr hsc_env mode rdr_expr + = runTcInteractive hsc_env $ + do { + + (rn_expr, _fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Typecheck the expression + ((tclvl, res_ty), lie) + <- captureTopConstraints $ + pushTcLevelM $ + tcInferSigma inst rn_expr ; + + -- Generalise + uniq <- newUnique ; + let { fresh_it = itName uniq (getLocA rdr_expr) } ; + ((qtvs, dicts, _, _), residual) + <- captureConstraints $ + simplifyInfer tclvl infer_mode + [] {- No sig vars -} + [(fresh_it, res_ty)] + lie ; + + -- Ignore the dictionary bindings + _ <- perhaps_disable_default_warnings $ + simplifyInteractive residual ; + + let { all_expr_ty = mkInfForAllTys qtvs $ + mkPhiTy (map idType dicts) res_ty } ; + ty <- liftZonkM $ zonkTcType all_expr_ty ; + + -- See Note [Normalising the type in :type] + fam_envs <- tcGetFamInstEnvs ; + let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty + -- normaliseType returns a coercion which we discard, so the Role is irrelevant. + ; final_type = if isSigmaTy res_ty then ty else normalised_type } ; + return final_type } + where + -- Optionally instantiate the type of the expression + -- See Note [TcRnExprMode] + (inst, infer_mode, perhaps_disable_default_warnings) = case mode of + TM_Inst -> (False, NoRestrictions, id) + TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) + +{- Note [Implementing :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider :type const + +We want forall a b. a -> b -> a +and not forall {a}{b}. a -> b -> a + +The latter is what we'd get if we eagerly instantiated and then +re-generalised with Inferred binders. It makes a difference, because +it tells us we where we can use Visible Type Application (VTA). + +And also for :type const @Int +we want forall b. Int -> b -> Int +and not forall {b}. Int -> b -> Int + +Solution: use tcInferSigma, which in turn uses tcInferApp, which +has a special case for application chains. + +Note [Normalising the type in :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In :t we usually normalise the type (to simplify type functions) +before displaying the result. Reason (see #10321): otherwise we may show +types like + :: Vec (1+2) Int +rather than the simpler + :: Vec 3 Int +In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason. + +However this normalisation is less helpful when is just +an identifier, whose user-written type happens to contain type-function +applications. E.g. (#20974) + test :: F [Monad, A, B] m => m () +where F is a type family. If we say `:t test`, we'd prefer to see +the type family un-expanded. + +We adopt the following ad-hoc solution: if the type inferred for +(before generalisation, namely res_ty) is a SigmaType (i.e. is not +fully instantiated) then do not normalise; otherwise normalise. +This is not ideal; for example, suppose x :: F Int. Then + :t x +would be normalised because `F Int` is not a SigmaType. But +anything here is ad-hoc, and it's a user-sought improvement. +-} + +-------------------------- +tcRnImportDecls :: HscEnv + -> [LImportDecl GhcPs] + -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) +-- Find the new chunk of GlobalRdrEnv created by this list of import +-- decls. In contract tcRnImports *extends* the TcGblEnv. +tcRnImportDecls hsc_env import_decls + = runTcInteractive hsc_env $ + do { gbl_env <- updGblEnv zap_rdr_env $ + tcRnImports hsc_env $ map (,text "is directly imported") import_decls + ; return (tcg_rdr_env gbl_env) } + where + zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } + +-- tcRnType just finds the kind of a type +tcRnType :: HscEnv + -> ZonkFlexi + -> Bool -- Normalise the returned type + -> LHsType GhcPs + -> IO (Messages TcRnMessage, Maybe (Type, Kind)) +tcRnType hsc_env flexi normalise rdr_type + = runTcInteractive hsc_env $ + setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (HsWC { hswc_ext = wcs, hswc_body = rn_sig_type@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body })) }, _fvs) + -- we are using 'rnHsSigWcType' to bind the unbound type variables + -- and in combination with 'tcOuterTKBndrs' we are able to + -- implicitly quantify them as if the user wrote 'forall' by + -- hand (see #19217). This allows kind check to work in presence + -- of free type variables : + -- ghci> :k [a] + -- [a] :: * + <- rnHsSigWcType GHCiCtx (mkHsWildCardBndrs $ noLocA (mkHsImplicitSigType rdr_type)) + -- The type can have wild cards, but no implicit + -- generalisation; e.g. :kind (T _) + ; failIfErrsM + + -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here + + -- Now kind-check the type + -- It can have any rank or kind + -- First bring into scope any wildcards + ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_sig_type]) + ; si <- mkSkolemInfo $ SigTypeSkol (GhciCtxt True) + ; ((_, (ty, kind)), wanted) + <- captureTopConstraints $ + pushTcLevelM_ $ + bindNamedWildCardBinders wcs $ \ wcs' -> + do { mapM_ emitNamedTypeHole wcs' + ; tcOuterTKBndrs si outer_bndrs $ tcInferLHsTypeUnsaturated body } + -- Since all the wanteds are equalities, the returned bindings will be empty + ; empty_binds <- simplifyTop wanted + ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) + + -- Do kind generalisation; see Note [Kind-generalise in tcRnType] + ; kvs <- kindGeneralizeAll unkSkol kind + + ; ty <- initZonkEnv flexi $ zonkTcTypeToTypeX ty + + -- Do validity checking on type + ; checkValidType (GhciCtxt True) ty + + -- Optionally (:k vs :k!) normalise the type. Does two things: + -- normaliseType: expand type-family applications + -- expandTypeSynonyms: expand type synonyms (#18828) + ; fam_envs <- tcGetFamInstEnvs + ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $ + normaliseType fam_envs Nominal ty + | otherwise = ty + + ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') + ; return (ty', mkInfForAllTys kvs (typeKind ty')) } + + +{- Note [TcRnExprMode] +~~~~~~~~~~~~~~~~~~~~~~ +How should we infer a type when a user asks for the type of an expression e +at the GHCi prompt? We offer 2 different possibilities, described below. Each +considers this example, with -fprint-explicit-foralls enabled. See also +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst + +:type / TM_Inst + + In this mode, we report the type obtained by instantiating only the + /inferred/ quantifiers of e's type, solving constraints, and + re-generalising, as discussed in #11376. + + > :type reverse + reverse :: forall a. [a] -> [a] + + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + > :type foo @Int + forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String + + Note that Show Int is still reported, because the solver never got a chance + to see it. + +:type +d / TM_Default + + This mode is for the benefit of users who wish to see instantiations + of generalized types, and in particular to instantiate Foldable and + Traversable. In this mode, all type variables (inferred or + specified) are instantiated. Because GHCi uses + -XExtendedDefaultRules, this means that Foldable and Traversable are + defaulted. + + > :type +d reverse + reverse :: forall {a}. [a] -> [a] + + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + > :type +d foo @Int + Int -> [Integer] -> String + + Note that this mode can sometimes lead to a type error, if a type variable is + used with a defaultable class but cannot actually be defaulted: + + bar :: (Num a, Monoid a) => a -> a + > :type +d bar + ** error ** + + The error arises because GHC tries to default a but cannot find a concrete + type in the defaulting list that is both Num and Monoid. (If this list is + modified to include an element that is both Num and Monoid, the defaulting + would succeed, of course.) + + Note that the variables and constraints are reordered here, because this + is possible during regeneralization. Also note that the variables are + reported as Inferred instead of Specified. + +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type, even when PolyKinds is not otherwise on. +This gives the right default behaviour at the GHCi prompt, where if +you say ":k T", and T has a polymorphic kind, you'd like to see that +polymorphism. Of course. If T isn't kind-polymorphic you won't get +anything unexpected, but the apparent *loss* of polymorphism, for +types that you know are polymorphic, is quite surprising. See Trac +#7688 for a discussion. + +Note that the goal is to generalise the *kind of the type*, not +the type itself! Example: + ghci> data SameKind :: k -> k -> Type + ghci> :k SameKind _ + +We want to get `k -> Type`, not `Any -> Type`, which is what we would +get without kind-generalisation. Note that `:k SameKind` is OK, as +GHC will not instantiate SameKind here, and so we see its full kind +of `forall k. k -> k -> Type`. + +************************************************************************ +* * + tcRnDeclsi +* * +************************************************************************ + +tcRnDeclsi exists to allow class, data, and other declarations in GHCi. +-} + +tcRnDeclsi :: HscEnv + -> [LHsDecl GhcPs] + -> IO (Messages TcRnMessage, Maybe TcGblEnv) +tcRnDeclsi hsc_env local_decls + = runTcInteractive hsc_env $ + tcRnSrcDecls False Nothing local_decls + +externaliseAndTidyId :: Module -> Id -> TcM Id +externaliseAndTidyId this_mod id + = do { name' <- externaliseName this_mod (idName id) + ; return $ globaliseId id + `setIdName` name' + `setIdType` tidyTopType (idType id) } + + +{- +************************************************************************ +* * + More GHCi stuff, to do with browsing and getting info +* * +************************************************************************ +-} + +-- | ASSUMES that the module is either in the 'HomePackageTable' or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) +getModuleInterface hsc_env mod + = runTcInteractive hsc_env $ + loadModuleInterface (text "getModuleInterface") mod + +tcRnLookupRdrName :: HscEnv -> LocatedN RdrName + -> IO (Messages TcRnMessage, Maybe [Name]) +-- ^ Find all the Names that this RdrName could mean, in GHCi +tcRnLookupRdrName hsc_env (L loc rdr_name) + = runTcInteractive hsc_env $ + setSrcSpanA loc $ + do { -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names = dataTcOccs rdr_name + ; names_s <- mapM lookupInfoOccRn rdr_names + ; let names = concat names_s + ; when (null names) (addErrTc $ mkTcRnNotInScope rdr_name NotInScope) + ; return names } + +tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) +tcRnLookupName hsc_env name + = runTcInteractive hsc_env $ + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: + +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + +tcRnGetInfo :: HscEnv + -> Name + -> IO ( Messages TcRnMessage + , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) + +-- Used to implement :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env name + = runTcInteractive hsc_env $ + do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + + ; thing <- tcRnLookupName' name + ; fixity <- lookupFixityRn name + ; (cls_insts, fam_insts) <- lookupInsts thing + ; let info = lookupKnownNameInfo name + ; return (thing, fixity, cls_insts, fam_insts, info) } + + +-- Lookup all class and family instances for a type constructor. +-- +-- This function filters all instances in the type environment, so there +-- is a lot of duplicated work if it is called many times in the same +-- type environment. If this becomes a problem, the NameEnv computed +-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions +-- could be changed to consult that index. +lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) +lookupInsts (ATyCon tc) + = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + + -- Return only the instances relevant to the given thing, i.e. + -- the instances whose head contains the thing's name. + ; let cls_insts = + [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , instIsVisible vis_mods ispec + , tc_name `elemNameSet` orphNamesOfClsInst ispec ] + ; let fam_insts = + [ fispec + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , tc_name `elemNameSet` orphNamesOfFamInst fispec ] + ; return (cls_insts, fam_insts) } + where + tc_name = tyConName tc + +lookupInsts _ = return ([],[]) + +loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () +-- Load the interface for everything that is in scope unqualified +-- This is so that we can accurately report the instances for +-- something +loadUnqualIfaces hsc_env ictxt + = initIfaceTcRn $ + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + home_unit = hsc_home_unit hsc_env + + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (icReaderEnv ictxt) + , let name = greName gre + , nameIsFromExternalPackage home_unit name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified + doc = text "Need interface for module whose export(s) are in scope unqualified" + + + +{- +************************************************************************ +* * + Debugging output + This is what happens when you do -ddump-types +* * +************************************************************************ +-} + +-- | Dump, with a banner, if -ddump-rn +rnDump :: (Outputable a, Data a) => a -> TcRn () +rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) + +tcDump :: TcGblEnv -> TcRn () +tcDump env + = do { unit_state <- hsc_units <$> getTopEnv ; + logger <- getLogger ; + + -- Dump short output if -ddump-types or -ddump-tc + when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) + (dumpTcRn True Opt_D_dump_types + "" FormatText (pprWithUnitState unit_state short_dump)) ; + + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; + + -- Dump bindings as an hsSyn AST if -ddump-tc-ast + dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump + } + where + short_dump = pprTcGblEnv env + full_dump = pprLHsBinds (tcg_binds env) + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords + ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env) + +-- It's unpleasant having both pprModGuts and pprModDetails here +pprTcGblEnv :: TcGblEnv -> SDoc +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_imports = imports }) + = getPprDebug $ \debug -> + vcat [ ppr_types debug type_env + , ppr_tycons debug fam_insts type_env + , ppr_datacons debug type_env + , ppr_patsyns type_env + , ppr_insts insts + , ppr_fam_insts fam_insts + , ppr_rules rules + , text "Dependent modules:" <+> + (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) + , text "Dependent packages:" <+> + ppr (S.toList $ imp_dep_direct_pkgs imports)] + -- The use of sort is just to reduce unnecessary + -- wobbling in testsuite output + +ppr_rules :: [LRuleDecl GhcTc] -> SDoc +ppr_rules rules + = ppUnless (null rules) $ + hang (text "RULES") + 2 (vcat (map ppr rules)) + +ppr_types :: Bool -> TypeEnv -> SDoc +ppr_types debug type_env + = ppr_things "TYPE SIGNATURES" ppr_sig + (sortBy (comparing getOccName) ids) + where + ids = [id | id <- typeEnvIds type_env, want_sig id] + want_sig id + | debug = True + | otherwise = hasTopUserName id + && case idDetails id of + VanillaId -> True + WorkerLikeId {} -> True + RecSelId {} -> True + ClassOpId {} -> True + FCallId {} -> True + _ -> False -- Data cons (workers and wrappers), pattern synonyms, -- etc are suppressed (unless -dppr-debug), -- because they appear elsewhere diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot --- a/compiler/GHC/Tc/Module.hs-boot +++ b/compiler/GHC/Tc/Module.hs-boot @@ -1,12 +1,7 @@ module GHC.Tc.Module where -import GHC.Prelude +import GHC.Types.SourceFile(HsBootOrSig) import GHC.Types.TyThing(TyThing) -import GHC.Tc.Errors.Types (TcRnMessage) import GHC.Tc.Types (TcM) -import GHC.Types.Name (Name) -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> TcRnMessage -badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage +checkBootDeclM :: HsBootOrSig -> TyThing -> TyThing -> TcM () 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 @@ -1,3332 +1,3767 @@ -{-# LANGUAGE RecursiveDo #-} - -module GHC.Tc.Solver( - InferMode(..), simplifyInfer, findInferredDiff, - growThetaTyVars, - simplifyAmbiguityCheck, - simplifyDefault, - simplifyTop, simplifyTopImplic, - simplifyInteractive, - solveEqualities, - pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX, - reportUnsolvedEqualities, - simplifyWantedsTcM, - tcCheckGivens, - tcCheckWanteds, - tcNormalise, - - captureTopConstraints, - - simplifyTopWanteds, - - promoteTyVarSet, simplifyAndEmitFlatConstraints, - - -- For Rules we need these - solveWanteds, - approximateWC - - ) where - -import GHC.Prelude - -import GHC.Data.Bag -import GHC.Core.Class -import GHC.Driver.Session -import GHC.Tc.Utils.Instantiate -import GHC.Data.List.SetOps -import GHC.Types.Name -import GHC.Types.Id( idType ) -import GHC.Utils.Outputable -import GHC.Builtin.Utils -import GHC.Builtin.Names -import GHC.Tc.Errors -import GHC.Tc.Errors.Types -import GHC.Tc.Types.Evidence -import GHC.Tc.Solver.Interact -import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) -import GHC.Tc.Solver.Rewrite ( rewriteType ) -import GHC.Tc.Utils.Unify ( buildTvImplication ) -import GHC.Tc.Utils.TcMType as TcM -import GHC.Tc.Utils.Monad as TcM -import GHC.Tc.Solver.InertSet -import GHC.Tc.Solver.Monad as TcS -import GHC.Tc.Types.Constraint -import GHC.Tc.Instance.FunDeps -import GHC.Core.Predicate -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType -import GHC.Core.Type -import GHC.Core.Ppr -import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) -import GHC.Builtin.Types ( liftedRepTy, liftedDataConTy ) -import GHC.Core.Unify ( tcMatchTyKi ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit - , DefaultingStrategy(..), NonStandardDefaultingStrategy(..) ) -import GHC.Types.Error -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import GHC.Data.Maybe ( mapMaybe, isJust ) - -{- -********************************************************************************* -* * -* External interface * -* * -********************************************************************************* --} - -captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureTopConstraints m) runs m, and returns the type constraints it --- generates plus the constraints produced by static forms inside. --- If it fails with an exception, it reports any insolubles --- (out of scope variables) before doing so --- --- captureTopConstraints is used exclusively by GHC.Tc.Module at the top --- level of a module. --- --- Importantly, if captureTopConstraints propagates an exception, it --- reports any insoluble constraints first, lest they be lost --- altogether. This is important, because solveEqualities (maybe --- other things too) throws an exception without adding any error --- messages; it just puts the unsolved constraints back into the --- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors] --- #16376 is an example of what goes wrong if you don't do this. --- --- NB: the caller should bring any environments into scope before --- calling this, so that the reportUnsolved has access to the most --- complete GlobalRdrEnv -captureTopConstraints thing_inside - = do { static_wc_var <- TcM.newTcRef emptyWC ; - ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ - TcM.tryCaptureConstraints thing_inside - ; stWC <- TcM.readTcRef static_wc_var - - -- See GHC.Tc.Utils.Monad Note [Constraints and errors] - -- If the thing_inside threw an exception, but generated some insoluble - -- constraints, report the latter before propagating the exception - -- Otherwise they will be lost altogether - ; case mb_res of - Just res -> return (res, lie `andWC` stWC) - Nothing -> do { _ <- simplifyTop lie; failM } } - -- This call to simplifyTop is the reason - -- this function is here instead of GHC.Tc.Utils.Monad - -- We call simplifyTop so that it does defaulting - -- (esp of runtime-reps) before reporting errors - -simplifyTopImplic :: Bag Implication -> TcM () -simplifyTopImplic implics - = do { empty_binds <- simplifyTop (mkImplicWC implics) - - -- Since all the inputs are implications the returned bindings will be empty - ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) - - ; return () } - -simplifyTop :: WantedConstraints -> TcM (Bag EvBind) --- Simplify top-level constraints --- Usually these will be implications, --- but when there is nothing to quantify we don't wrap --- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; ((final_wc, unsafe_ol), binds1) <- runTcS $ - do { final_wc <- simplifyTopWanteds wanteds - ; unsafe_ol <- getSafeOverlapFailures - ; return (final_wc, unsafe_ol) } - ; traceTc "End simplifyTop }" empty - - ; binds2 <- reportUnsolved final_wc - - ; traceTc "reportUnsolved (unsafe overlapping) {" empty - ; unless (isEmptyCts unsafe_ol) $ do { - -- grab current error messages and clear, warnAllUnsolved will - -- update error messages which we'll grab and then restore saved - -- messages. - ; errs_var <- getErrsVar - ; saved_msg <- TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var emptyMessages - - ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol } - - ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer (mkMessages whyUnsafe) - } - ; traceTc "reportUnsolved (unsafe overlapping) }" empty - - ; return (evBindMapBinds binds1 `unionBags` binds2) } - -pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a --- Push level, and solve all resulting equalities --- If there are any unsolved equalities, report them --- and fail (in the monad) --- --- Panics if we solve any non-equality constraints. (In runTCSEqualities --- we use an error thunk for the evidence bindings.) -pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside - = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX - "pushLevelAndSolveEqualities" thing_inside - ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted - ; return res } - -pushLevelAndSolveEqualitiesX :: String -> TcM a - -> TcM (TcLevel, WantedConstraints, a) --- Push the level, gather equality constraints, and then solve them. --- Returns any remaining unsolved equalities. --- Does not report errors. --- --- Panics if we solve any non-equality constraints. (In runTCSEqualities --- we use an error thunk for the evidence bindings.) -pushLevelAndSolveEqualitiesX callsite thing_inside - = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite) - ; (tclvl, (wanted, res)) - <- pushTcLevelM $ - do { (res, wanted) <- captureConstraints thing_inside - ; wanted <- runTcSEqualities (simplifyTopWanteds wanted) - ; return (wanted,res) } - ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted - , text "Level:" <+> ppr tclvl ]) - ; return (tclvl, wanted, res) } - --- | Type-check a thing that emits only equality constraints, solving any --- constraints we can and re-emitting constraints that we can't. --- Use this variant only when we'll get another crack at it later --- See Note [Failure in local type signatures] --- --- Panics if we solve any non-equality constraints. (In runTCSEqualities --- we use an error thunk for the evidence bindings.) -solveEqualities :: String -> TcM a -> TcM a -solveEqualities callsite thing_inside - = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite) - ; (res, wanted) <- captureConstraints thing_inside - ; simplifyAndEmitFlatConstraints wanted - -- simplifyAndEmitFlatConstraints fails outright unless - -- the only unsolved constraints are soluble-looking - -- equalities that can float out - ; traceTc "solveEqualities }" empty - ; return res } - -simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () --- See Note [Failure in local type signatures] -simplifyAndEmitFlatConstraints wanted - = do { -- Solve and zonk to establish the - -- preconditions for floatKindEqualities - wanted <- runTcSEqualities (solveWanteds wanted) - ; wanted <- TcM.zonkWC wanted - - ; traceTc "emitFlatConstraints {" (ppr wanted) - ; case floatKindEqualities wanted of - Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted) - -- Emit the bad constraints, wrapped in an implication - -- See Note [Wrapping failing kind equalities] - ; tclvl <- TcM.getTcLevel - ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted - -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ - -- it's OK to use unkSkol | we must increase the TcLevel, - -- because we don't bind | as explained in - -- any skolem variables here | Note [Wrapping failing kind equalities] - ; emitImplication implic - ; failM } - Just (simples, errs) - -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) - ; traceTc "emitFlatConstraints }" $ - vcat [ text "simples:" <+> ppr simples - , text "errs: " <+> ppr errs ] - -- Holes and other delayed errors don't need promotion - ; emitDelayedErrors errs - ; emitSimples simples } } - -floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) --- Float out all the constraints from the WantedConstraints, --- Return Nothing if any constraints can't be floated (captured --- by skolems), or if there is an insoluble constraint, or --- IC_Telescope telescope error --- Precondition 1: we have tried to solve the 'wanteds', both so that --- the ic_status field is set, and because solving can make constraints --- more floatable. --- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities --- is not monadic --- See Note [floatKindEqualities vs approximateWC] -floatKindEqualities wc = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) - float_wc trapping_tvs (WC { wc_simple = simples - , wc_impl = implics - , wc_errors = errs }) - | all is_floatable simples - = do { (inner_simples, inner_errs) - <- flatMapBagPairM (float_implic trapping_tvs) implics - ; return ( simples `unionBags` inner_simples - , errs `unionBags` inner_errs) } - | otherwise - = Nothing - where - is_floatable ct - | insolubleEqCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs - - float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError) - float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs - , ic_skols = skols, ic_status = status }) - | isInsolubleStatus status - = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope - | otherwise - = do { (simples, holes) <- float_wc new_trapping_tvs wanted - ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $ - Nothing - -- If there are some constraints to float out, but we can't - -- because we don't float out past local equalities - -- (c.f GHC.Tc.Solver.approximateWC), then fail - ; return (simples, holes) } - where - new_trapping_tvs = trapping_tvs `extendVarSetList` skols - - -{- Note [Failure in local type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind checking a type signature, we like to fail fast if we can't -solve all the kind equality constraints, for two reasons: - - * A kind-bogus type signature may cause a cascade of knock-on - errors if we let it pass - - * More seriously, we don't have a convenient term-level place to add - deferred bindings for unsolved kind-equality constraints. In - earlier GHCs this led to un-filled-in coercion holes, which caused - GHC to crash with "fvProv falls into a hole" See #11563, #11520, - #11516, #11399 - -But what about /local/ type signatures, mentioning in-scope type -variables for which there might be 'given' equalities? For these we -might not be able to solve all the equalities locally. Here's an -example (T15076b): - - class (a ~ b) => C a b - data SameKind :: k -> k -> Type where { SK :: SameKind a b } - - bar :: forall (a :: Type) (b :: Type). - C a b => Proxy a -> Proxy b -> () - bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) - -Consider the type signature on 'undefined'. It's ill-kinded unless -a~b. But the superclass of (C a b) means that indeed (a~b). So all -should be well. BUT it's hard to see that when kind-checking the signature -for undefined. We want to emit a residual (a~b) constraint, to solve -later. - -Another possibility is that we might have something like - F alpha ~ [Int] -where alpha is bound further out, which might become soluble -"later" when we learn more about alpha. So we want to emit -those residual constraints. - -BUT it's no good simply wrapping all unsolved constraints from -a type signature in an implication constraint to solve later. The -problem is that we are going to /use/ that signature, including -instantiate it. Say we have - f :: forall a. (forall b. blah) -> blah2 - f x = -To typecheck the definition of f, we have to instantiate those -foralls. Moreover, any unsolved kind equalities will be coercion -holes in the type. If we naively wrap them in an implication like - forall a. (co1:k1~k2, forall b. co2:k3~k4) -hoping to solve it later, we might end up filling in the holes -co1 and co2 with coercions involving 'a' and 'b' -- but by now -we've instantiated the type. Chaos! - -Moreover, the unsolved constraints might be skolem-escape things, and -if we proceed with f bound to a nonsensical type, we get a cascade of -follow-up errors. For example polykinds/T12593, T15577, and many others. - -So here's the plan (see tcHsSigType): - -* pushLevelAndSolveEqualitiesX: try to solve the constraints - -* kindGeneraliseSome: do kind generalisation - -* buildTvImplication: build an implication for the residual, unsolved - constraint - -* simplifyAndEmitFlatConstraints: try to float out every unsolved equality - inside that implication, in the hope that it constrains only global - type variables, not the locally-quantified ones. - - * If we fail, or find an insoluble constraint, emit the implication, - so that the errors will be reported, and fail. - - * If we succeed in floating all the equalities, promote them and - re-emit them as flat constraint, not wrapped at all (since they - don't mention any of the quantified variables. - -* Note that this float-and-promote step means that anonymous - wildcards get floated to top level, as we want; see - Note [Checking partial type signatures] in GHC.Tc.Gen.HsType. - -All this is done: - -* In GHC.Tc.Gen.HsType.tcHsSigType, as above - -* solveEqualities. Use this when there no kind-generalisation - step to complicate matters; then we don't need to push levels, - and can solve the equalities immediately without needing to - wrap it in an implication constraint. (You'll generally see - a kindGeneraliseNone nearby.) - -* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to - pushLevelAndSolveEqualitiesX, followed by quantification, and - then reportUnsolvedEqualities. - - NB: we call reportUnsolvedEqualities before zonkTcTypeToType - because the latter does not expect to see any un-filled-in - coercions, which will happen if we have unsolved equalities. - By calling reportUnsolvedEqualities first, which fails after - reporting errors, we avoid that happening. - -See also #18062, #11506 - -Note [Wrapping failing kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In simplifyAndEmitFlatConstraints, if we fail to get down to simple -flat constraints we will -* re-emit the constraints so that they are reported -* fail in the monad -But there is a Terrible Danger that, if -fdefer-type-errors is on, and -we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll -report only a warning and proceed with compilation. But if we ever fail -in the monad it should be fatal; we should report an error and stop after -the type checker. If not, chaos results: #19142. - -Our solution is this: -* Even with -fdefer-type-errors, inside an implication with no place for - value bindings (ic_binds = CoEvBindsVar), report failing equalities as - errors. We have to do this anyway; see GHC.Tc.Errors - Note [Failing equalities with no evidence bindings]. - -* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication - to wrap the failing constraint in a degenerate implication (no - skolems, no theta), with ic_binds = CoEvBindsVar. This setting of - `ic_binds` means that any failing equalities will lead to an - error not a warning, irrespective of -fdefer-type-errors: see - Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors, - and `maybeSwitchOffDefer` in that module. - - We still take care to bump the TcLevel of the implication. Partly, - that ensures that nested implications have increasing level numbers - which seems nice. But more specifically, suppose the outer level - has a Given `(C ty)`, which has pending (not-yet-expanded) - superclasses. Consider what happens when we process this implication - constraint (which we have re-emitted) in that context: - - in the inner implication we'll call `getPendingGivenScs`, - - we /do not/ want to get the `(C ty)` from the outer level, - lest we try to add an evidence term for the superclass, - which we can't do because we have specifically set - `ic_binds` = `CoEvBindsVar`. - - as `getPendingGivenSCcs is careful to only get Givens from - the /current/ level, and we bumped the `TcLevel` of the implication, - we're OK. - - TL;DR: bump the `TcLevel` when creating the nested implication. - If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043). - - -We re-emit the implication rather than reporting the errors right now, -so that the error messages are improved by other solving and defaulting. -e.g. we prefer - Cannot match 'Type->Type' with 'Type' -to Cannot match 'Type->Type' with 'TYPE r0' - - -Note [floatKindEqualities vs approximateWC] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -floatKindEqualities and approximateWC are strikingly similar to each -other, but - -* floatKindEqualites tries to float /all/ equalities, and fails if - it can't, or if any implication is insoluble. -* approximateWC just floats out any constraints - (not just equalities) that can float; it never fails. --} - - -reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel - -> WantedConstraints -> TcM () --- Reports all unsolved wanteds provided; fails in the monad if there are any. --- --- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to --- provide skolem info for any errors. -reportUnsolvedEqualities skol_info skol_tvs tclvl wanted - = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted - -report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel - -> WantedConstraints -> TcM () -report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted - | isEmptyWC wanted - = return () - - | otherwise -- NB: we build an implication /even if skol_tvs is empty/, - -- just to ensure that our level invariants hold, specifically - -- (WantedInv). See Note [TcLevel invariants]. - = checkNoErrs $ -- Fail - do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted - ; reportAllUnsolved (mkImplicWC (unitBag implic)) } - - --- | Simplify top-level constraints, but without reporting any unsolved --- constraints nor unsafe overlapping. -simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints - -- See Note [Top-level Defaulting Plan] -simplifyTopWanteds wanteds - = do { wc_first_go <- nestTcS (solveWanteds wanteds) - -- This is where the main work happens - ; dflags <- getDynFlags - ; try_tyvar_defaulting dflags wc_first_go } - where - try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints - try_tyvar_defaulting dflags wc - | isEmptyWC wc - = return wc - | insolubleWC wc - , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] - = try_class_defaulting wc - | otherwise - = do { -- Need to zonk first, as the WantedConstraints are not yet zonked. - ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) - ; let defaultable_tvs = filter can_default free_tvs - can_default tv - = isTyVar tv - -- Weed out coercion variables. - - && isMetaTyVar tv - -- Weed out runtime-skolems in GHCi, which we definitely - -- shouldn't try to default. - - && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc) - -- Weed out variables for which defaulting would be unhelpful, - -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk]. - - ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects - ; if or defaulted - then do { wc_residual <- nestTcS (solveWanteds wc) - -- See Note [Must simplify after defaulting] - ; try_class_defaulting wc_residual } - else try_class_defaulting wc } -- No defaulting took place - - try_class_defaulting :: WantedConstraints -> TcS WantedConstraints - try_class_defaulting wc - | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] - = try_callstack_defaulting wc - | otherwise -- See Note [When to do type-class defaulting] - = do { something_happened <- applyDefaultingRules wc - -- See Note [Top-level Defaulting Plan] - ; if something_happened - then do { wc_residual <- nestTcS (solveWanteds wc) - ; try_class_defaulting wc_residual } - -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - else try_callstack_defaulting wc } - - try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints - try_callstack_defaulting wc - | isEmptyWC wc - = return wc - | otherwise - = defaultCallStacks wc - --- | Default any remaining @CallStack@ constraints to empty @CallStack@s. -defaultCallStacks :: WantedConstraints -> TcS WantedConstraints --- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence -defaultCallStacks wanteds - = do simples <- handle_simples (wc_simple wanteds) - mb_implics <- mapBagM handle_implic (wc_impl wanteds) - return (wanteds { wc_simple = simples - , wc_impl = catBagMaybes mb_implics }) - - where - - handle_simples simples - = catBagMaybes <$> mapBagM defaultCallStack simples - - handle_implic :: Implication -> TcS (Maybe Implication) - -- The Maybe is because solving the CallStack constraint - -- may well allow us to discard the implication entirely - handle_implic implic - | isSolvedStatus (ic_status implic) - = return (Just implic) - | otherwise - = do { wanteds <- setEvBindsTcS (ic_binds implic) $ - -- defaultCallStack sets a binding, so - -- we must set the correct binding group - defaultCallStacks (ic_wanted implic) - ; setImplicationStatus (implic { ic_wanted = wanteds }) } - - defaultCallStack ct - | ClassPred cls tys <- classifyPredType (ctPred ct) - , Just {} <- isCallStackPred cls tys - = do { solveCallStack (ctEvidence ct) EvCsEmpty - ; return Nothing } - - defaultCallStack ct - = return (Just ct) - - -{- Note [When to do type-class defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC -was false, on the grounds that defaulting can't help solve insoluble -constraints. But if we *don't* do defaulting we may report a whole -lot of errors that would be solved by defaulting; these errors are -quite spurious because fixing the single insoluble error means that -defaulting happens again, which makes all the other errors go away. -This is jolly confusing: #9033. - -So it seems better to always do type-class defaulting. - -However, always doing defaulting does mean that we'll do it in -situations like this (#5934): - run :: (forall s. GenST s) -> Int - run = fromInteger 0 -We don't unify the return type of fromInteger with the given function -type, because the latter involves foralls. So we're left with - (Num alpha, alpha ~ (forall s. GenST s) -> Int) -Now we do defaulting, get alpha := Integer, and report that we can't -match Integer with (forall s. GenST s) -> Int. That's not totally -stupid, but perhaps a little strange. - -Another potential alternative would be to suppress *all* non-insoluble -errors if there are *any* insoluble errors, anywhere, but that seems -too drastic. - -Note [Don't default in syntactic equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are unsolved syntactic equalities such as - - rr[sk] ~S# alpha[conc] - -we should not default alpha, lest we obtain a poor error message such as - - Couldn't match kind `rr' with `LiftedRep' - -We would rather preserve the original syntactic equality to be -reported to the user, especially as the concrete metavariable alpha -might store an informative origin for the user. - -Note [Must simplify after defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a deeply buried constraint - (t:*) ~ (a:Open) -which we couldn't solve because of the kind incompatibility, and 'a' is free. -Then when we default 'a' we can solve the constraint. And we want to do -that before starting in on type classes. We MUST do it before reporting -errors, because it isn't an error! #7967 was due to this. - -Note [Top-level Defaulting Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have considered two design choices for where/when to apply defaulting. - (i) Do it in SimplCheck mode only /whenever/ you try to solve some - simple constraints, maybe deep inside the context of implications. - This used to be the case in GHC 7.4.1. - (ii) Do it in a tight loop at simplifyTop, once all other constraints have - finished. This is the current story. - -Option (i) had many disadvantages: - a) Firstly, it was deep inside the actual solver. - b) Secondly, it was dependent on the context (Infer a type signature, - or Check a type signature, or Interactive) since we did not want - to always start defaulting when inferring (though there is an exception to - this, see Note [Default while Inferring]). - c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: - f :: Int -> Bool - f x = const True (\y -> let w :: a -> a - w a = const a (y+1) - in w y) - We will get an implication constraint (for beta the type of y): - [untch=beta] forall a. 0 => Num beta - which we really cannot default /while solving/ the implication, since beta is - untouchable. - -Instead our new defaulting story is to pull defaulting out of the solver loop and -go with option (ii), implemented at SimplifyTop. Namely: - - First, have a go at solving the residual constraint of the whole - program - - Try to approximate it with a simple constraint - - Figure out derived defaulting equations for that simple constraint - - Go round the loop again if you did manage to get some equations - -Now, that has to do with class defaulting. However there exists type variable /kind/ -defaulting. Again this is done at the top-level and the plan is: - - At the top-level, once you had a go at solving the constraint, do - figure out /all/ the touchable unification variables of the wanted constraints. - - Apply defaulting to their kinds - -More details in Note [DefaultTyVar]. - -Note [Safe Haskell Overlapping Instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Safe Haskell, we apply an extra restriction to overlapping instances. The -motive is to prevent untrusted code provided by a third-party, changing the -behavior of trusted code through type-classes. This is due to the global and -implicit nature of type-classes that can hide the source of the dictionary. - -Another way to state this is: if a module M compiles without importing another -module N, changing M to import N shouldn't change the behavior of M. - -Overlapping instances with type-classes can violate this principle. However, -overlapping instances aren't always unsafe. They are just unsafe when the most -selected dictionary comes from untrusted code (code compiled with -XSafe) and -overlaps instances provided by other modules. - -In particular, in Safe Haskell at a call site with overlapping instances, we -apply the following rule to determine if it is a 'unsafe' overlap: - - 1) Most specific instance, I1, defined in an `-XSafe` compiled module. - 2) I1 is an orphan instance or a MPTC. - 3) At least one overlapped instance, Ix, is both: - A) from a different module than I1 - B) Ix is not marked `OVERLAPPABLE` - -This is a slightly involved heuristic, but captures the situation of an -imported module N changing the behavior of existing code. For example, if -condition (2) isn't violated, then the module author M must depend either on a -type-class or type defined in N. - -Secondly, when should these heuristics be enforced? We enforced them when the -type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. -This allows `-XUnsafe` modules to operate without restriction, and for Safe -Haskell inference to infer modules with unsafe overlaps as unsafe. - -One alternative design would be to also consider if an instance was imported as -a `safe` import or not and only apply the restriction to instances imported -safely. However, since instances are global and can be imported through more -than one path, this alternative doesn't work. - -Note [Safe Haskell Overlapping Instances Implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How is this implemented? It's complicated! So we'll step through it all: - - 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where - we check if a particular type-class method call is safe or unsafe. We do this - through the return type, `ClsInstLookupResult`, where the last parameter is a - list of instances that are unsafe to overlap. When the method call is safe, - the list is null. - - 2) `GHC.Tc.Solver.Interact.matchClassInst` -- This module drives the instance resolution - / dictionary generation. The return type is `ClsInstResult`, which either - says no instance matched, or one found, and if it was a safe or unsafe - overlap. - - 3) `GHC.Tc.Solver.Interact.doTopReactDict` -- Takes a dictionary / class constraint and - tries to resolve it by calling (in part) `matchClassInst`. The resolving - mechanism has a work list (of constraints) that it process one at a time. If - the constraint can't be resolved, it's added to an inert set. When compiling - an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know - compilation should fail. These are handled as normal constraint resolution - failures from here-on (see step 6). - - Otherwise, we may be inferring safety (or using `-Wunsafe`), and - compilation should succeed, but print warnings and/or mark the compiled module - as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds - the unsafe (but resolved!) constraint to the `inert_safehask` field of - `InertCans`. - - 4) `GHC.Tc.Solver.simplifyTop`: - * Call simplifyTopWanteds, the top-level function for driving the simplifier for - constraint resolution. - - * Once finished, call `getSafeOverlapFailures` to retrieve the - list of overlapping instances that were successfully resolved, - but unsafe. Remember, this is only applicable for generating warnings - (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` - cause compilation failure by not resolving the unsafe constraint at all. - - * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`, - while for resolved but unsafe overlapping dictionary constraints, call - `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a - warning message for the user. - - * In the case of `warnAllUnsolved` for resolved, but unsafe - dictionary constraints, we collect the generated warning - message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to - mark the module we are compiling as unsafe, passing the - warning message along as the reason. - - 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by - actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we - know is the constraint that is unresolved or unsafe. For dictionary, all we - know is that we need a dictionary of type C, but not what instances are - available and how they overlap. So we once again call `lookupInstEnv` to - figure that out so we can generate a helpful error message. - - 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in - IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. - - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling - `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference - failed. - -Note [No defaulting in the ambiguity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying constraints for the ambiguity check, we use -solveWanteds, not simplifyTopWanteds, so that we do no defaulting. -#11947 was an example: - f :: Num a => Int -> Int -This is ambiguous of course, but we don't want to default the -(Num alpha) constraint to (Num Int)! Doing so gives a defaulting -warning, but no error. - -Note [Defaulting insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a set of wanteds is insoluble, we have no hope of accepting the -program. Yet we do not stop constraint solving, etc., because we may -simplify the wanteds to produce better error messages. So, once -we have an insoluble constraint, everything we do is just about producing -helpful error messages. - -Should we default in this case or not? Let's look at an example (tcfail004): - - (f,g) = (1,2,3) - -With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). -Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) -find the latter more helpful. Several other test cases (e.g. tcfail005) suggest -similarly. So: we should not do class defaulting with insolubles. - -On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: - - f :: Integer i => i - f = 0 - -Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind -TYPE r0 -> Constraint and then complains that r0 is actually untouchable -(presumably, because it can't be sure if `Integer i` entails an equality). -If we default, we are told of a clash between (* -> Constraint) and Constraint. -The latter seems far better, suggesting we *should* do RuntimeRep-defaulting -even on insolubles. - -But, evidently, not always. Witness UnliftedNewtypesInfinite: - - newtype Foo = FooC (# Int#, Foo #) - -This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). -If we default RuntimeRep-vars, we get - - Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted - -which is just plain wrong. - -Another situation in which we don't want to default involves concrete metavariables. - -In equalities such as alpha[conc] ~# rr[sk] , alpha[conc] ~# RR beta[tau] -for a type family RR (all at kind RuntimeRep), we would prefer to report a -representation-polymorphism error rather than default alpha and get error: - - Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted` - -which is very confusing. For this reason, we weed out the concrete -metavariables participating in such equalities in nonDefaultableTyVarsOfWC. -Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could -become soluble after defaulting beta (see also #21430). - -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the -user does not want to hear about RuntimeRep stuff -- that is, when --fprint-explicit-runtime-reps is not set. -However, we must still take care not to default concrete type variables -participating in an equality with a non-concrete type, as seen in the -last example above. --} - ------------------- -simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () -simplifyAmbiguityCheck ty wanteds - = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _) <- runTcS $ solveWanteds wanteds - -- NB: no defaulting! See Note [No defaulting in the ambiguity check] - - ; traceTc "End simplifyAmbiguityCheck }" empty - - -- Normally report all errors; but with -XAllowAmbiguousTypes - -- report only insoluble ones, since they represent genuinely - -- inaccessible code - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; traceTc "reportUnsolved(ambig) {" empty - ; unless (allow_ambiguous && not (insolubleWC final_wc)) - (discardResult (reportUnsolved final_wc)) - ; traceTc "reportUnsolved(ambig) }" empty - - ; return () } - ------------------- -simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) -simplifyInteractive wanteds - = traceTc "simplifyInteractive" empty >> - simplifyTop wanteds - ------------------- -simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM Bool -- Return if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds)) - ; return (isEmptyWC unsolved) } - ------------------- -{- Note [Pattern match warnings with insoluble Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A pattern match on a GADT can introduce new type-level information, which needs -to be analysed in order to get the expected pattern match warnings. - -For example: - -> type IsBool :: Type -> Constraint -> type family IsBool a where -> IsBool Bool = () -> IsBool b = b ~ Bool -> -> data T a where -> MkTInt :: Int -> T Int -> MkTBool :: IsBool b => b -> T b -> -> f :: T Int -> Int -> f (MkTInt i) = i - -The pattern matching performed by `f` is complete: we can't ever call -`f (MkTBool b)`, as type-checking that application would require producing -evidence for `Int ~ Bool`, which can't be done. - -The pattern match checker uses `tcCheckGivens` to accumulate all the Given -constraints, and relies on `tcCheckGivens` to return Nothing if the -Givens become insoluble. `tcCheckGivens` in turn relies on `insolubleCt` -to identify these insoluble constraints. So the precise definition of -`insolubleCt` has a big effect on pattern match overlap warnings. - -To detect this situation, we check whether there are any insoluble Given -constraints. In the example above, the insoluble constraint was an -equality constraint, but it is also important to detect custom type errors: - -> type NotInt :: Type -> Constraint -> type family NotInt a where -> NotInt Int = TypeError (Text "That's Int, silly.") -> NotInt _ = () -> -> data R a where -> MkT1 :: a -> R a -> MkT2 :: NotInt a => R a -> -> foo :: R Int -> Int -> foo (MkT1 x) = x - -To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble -because it is a custom type error. -Failing to do so proved quite inconvenient for users, as evidence by the -tickets #11503 #14141 #16377 #20180. -Test cases: T11503, T14141. - -Examples of constraints that tcCheckGivens considers insoluble: - - Int ~ Bool, - - Coercible Float Word, - - TypeError msg. - -Non-examples: - - constraints which we know aren't satisfied, - e.g. Show (Int -> Int) when no such instance is in scope, - - Eq (TypeError msg), - - C (Int ~ Bool), with @class C (c :: Constraint)@. --} - -tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) --- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely --- contradictory. --- --- See Note [Pattern match warnings with insoluble Givens] above. -tcCheckGivens inerts given_ids = do - (sat, new_inerts) <- runTcSInerts inerts $ do - traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) - lcl_env <- TcS.getLclEnv - let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env - let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - solveSimpleGivens given_cts - insols <- getInertInsols - insols <- try_harder insols - traceTcS "checkGivens }" (ppr insols) - return (isEmptyBag insols) - return $ if sat then Just new_inerts else Nothing - where - try_harder :: Cts -> TcS Cts - -- Maybe we have to search up the superclass chain to find - -- an unsatisfiable constraint. Example: pmcheck/T3927b. - -- At the moment we try just once - try_harder insols - | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable - = return insols -- Hurrah -- stop now. - | otherwise - = do { pending_given <- getPendingGivenScs - ; new_given <- makeSuperClasses pending_given - ; solveSimpleGivens new_given - ; getInertInsols } - -tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool --- ^ Return True if the Wanteds are soluble, False if not -tcCheckWanteds inerts wanteds = do - cts <- newWanteds PatCheckOrigin wanteds - (sat, _new_inerts) <- runTcSInerts inerts $ do - traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) - -- See Note [Superclasses and satisfiability] - wcs <- solveWanteds (mkSimpleWC cts) - traceTcS "checkWanteds }" (ppr wcs) - return (isSolvedWC wcs) - return sat - --- | Normalise a type as much as possible using the given constraints. --- See @Note [tcNormalise]@. -tcNormalise :: InertSet -> Type -> TcM Type -tcNormalise inerts ty - = do { norm_loc <- getCtLocM PatCheckOrigin Nothing - ; (res, _new_inerts) <- runTcSInerts inerts $ - do { traceTcS "tcNormalise {" (ppr inerts) - ; ty' <- rewriteType norm_loc ty - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } - -{- Note [Superclasses and satisfiability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expand superclasses before starting, because (Int ~ Bool), has -(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) -as a superclass, and it's the latter that is insoluble. See -Note [The equality types story] in GHC.Builtin.Types.Prim. - -If we fail to prove unsatisfiability we (arbitrarily) try just once to -find superclasses, using try_harder. Reason: we might have a type -signature - f :: F op (Implements push) => .. -where F is a type function. This happened in #3972. - -We could do more than once but we'd have to have /some/ limit: in the -the recursive case, we would go on forever in the common case where -the constraints /are/ satisfiable (#10592 comment:12!). - -For straightforward situations without type functions the try_harder -step does nothing. - -Note [tcNormalise] -~~~~~~~~~~~~~~~~~~ -tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas -most invocations of the constraint solver are intended to simplify a set of -constraints or to decide if a particular set of constraints is satisfiable, -the purpose of tcNormalise is to take a type, plus some locally solved -constraints in the form of an InertSet, and normalise the type as much as -possible with respect to those constraints. - -It does *not* reduce type or data family applications or look through newtypes. - -Why is this useful? As one example, when coverage-checking an EmptyCase -expression, it's possible that the type of the scrutinee will only reduce -if some local equalities are solved for. See "Wrinkle: Local equalities" -in Note [Type normalisation] in "GHC.HsToCore.Pmc". - -To accomplish its stated goal, tcNormalise first initialises the solver monad -with the given InertCans, then uses rewriteType to simplify the desired type -with respect to the Givens in the InertCans. - -*********************************************************************************** -* * -* Inference -* * -*********************************************************************************** - -Note [Inferring the type of a let-bound variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = rhs - -To infer f's type we do the following: - * Gather the constraints for the RHS with ambient level *one more than* - the current one. This is done by the call - pushLevelAndCaptureConstraints (tcMonoBinds...) - in GHC.Tc.Gen.Bind.tcPolyInfer - - * Call simplifyInfer to simplify the constraints and decide what to - quantify over. We pass in the level used for the RHS constraints, - here called rhs_tclvl. - -This ensures that the implication constraint we generate, if any, -has a strictly-increased level compared to the ambient level outside -the let binding. - -Note [Inferring principal types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't always infer principal types. For instance, the inferred type for - -> f x = show [x] - -is - -> f :: Show a => a -> String - -This is not the most general type if we allow flexible contexts. -Indeed, if we try to write the following - -> g :: Show [a] => a -> String -> g x = f x - -we get the error: - - * Could not deduce (Show a) arising from a use of `f' - from the context: Show [a] - -Though replacing f x in the right-hand side of g with the definition -of f x works, the call to f x does not. This is the hallmark of -unprincip{led,al} types. - -Another example: - -> class C a -> class D a where -> d :: a -> instance C a => D a where -> d = undefined -> h _ = d -- argument is to avoid the monomorphism restriction - -The inferred type for h is - -> h :: C a => t -> a - -even though - -> h :: D a => t -> a - -is more general. - -The fix is easy: don't simplify constraints before inferring a type. -That is, have the inferred type quantify over all constraints that arise -in a definition's right-hand side, even if they are simplifiable. -Unfortunately, this would yield all manner of unwieldy types, -and so we won't do so. --} - --- | How should we choose which constraints to quantify over? -data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, - -- never quantifying over any constraints - | EagerDefaulting -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module", - -- the :type +d case; this mode refuses - -- to quantify over any defaultable constraint - | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies pickQuantifiablePreds - -instance Outputable InferMode where - ppr ApplyMR = text "ApplyMR" - ppr EagerDefaulting = text "EagerDefaulting" - ppr NoRestrictions = text "NoRestrictions" - -simplifyInfer :: TcLevel -- Used when generating the constraints - -> InferMode - -> [TcIdSigInst] -- Any signatures (possibly partial) - -> [(Name, TcTauType)] -- Variables to be generalised, - -- and their tau-types - -> WantedConstraints - -> TcM ([TcTyVar], -- Quantify over these type variables - [EvVar], -- ... and these constraints (fully zonked) - TcEvBinds, -- ... binding these evidence variables - Bool) -- True <=> the residual constraints are insoluble - -simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds - | isEmptyWC wanteds - = 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 - , (_,Bndr tv _) <- sig_inst_skols sig ] - psig_theta = [ pred | sig <- partial_sigs - , pred <- sig_inst_theta sig ] - - ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - - ; skol_info <- mkSkolemInfo (InferSkol name_taus) - ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars - ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, False) } - - | otherwise - = do { traceTc "simplifyInfer {" $ vcat - [ text "sigs =" <+> ppr sigs - , text "binds =" <+> ppr name_taus - , text "rhs_tclvl =" <+> ppr rhs_tclvl - , text "infer_mode =" <+> ppr infer_mode - , text "(unzonked) wanted =" <+> ppr wanteds - ] - - ; let psig_theta = concatMap sig_inst_theta partial_sigs - - -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_evs <- newWanteds AnnOrigin psig_theta - ; wanted_transformed - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ - solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) - -- psig_evs : see Note [Add signature contexts as wanteds] - -- See Note [Inferring principal types] - - -- Find quant_pred_candidates, the predicates that - -- we'll consider quantifying over - -- NB1: wanted_transformed does not include anything provable from - -- the psig_theta; it's just the extra bit - -- NB2: We do not do any defaulting when inferring a type, this can lead - -- to less polymorphic types, see Note [Default while Inferring] - ; wanted_transformed <- TcM.zonkWC wanted_transformed - ; let definite_error = insolubleWC wanted_transformed - -- See Note [Quantification with errors] - quant_pred_candidates - | definite_error = [] - | otherwise = ctsPreds (approximateWC False wanted_transformed) - - -- Decide what type variables and constraints to quantify - -- NB: quant_pred_candidates is already fully zonked - -- NB: bound_theta are constraints we want to quantify over, - -- including the psig_theta, which we always quantify over - -- NB: bound_theta are fully zonked - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl - name_taus partial_sigs - quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - - ; let full_theta = map idType bound_theta_vars - ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ]) - } - - - -- Now emit the residual constraint - ; emitResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs bound_theta_vars - wanted_transformed - - -- All done! - ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates - , text "psig_theta =" <+> ppr psig_theta - , text "bound_theta =" <+> pprCoreBinders bound_theta_vars - , text "qtvs =" <+> ppr qtvs - , text "definite_error =" <+> ppr definite_error ] - - ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } - -- NB: bound_theta_vars must be fully zonked - where - partial_sigs = filter isPartialSig sigs - --------------------- -emitResidualConstraints :: TcLevel -> EvBindsVar - -> [(Name, TcTauType)] - -> CoVarSet -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM () --- Emit the remaining constraints from the RHS. -emitResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs full_theta_vars wanteds - | isEmptyWC wanteds - = return () - - | otherwise - = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) - ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple - is_mono ct - | Just ct_ev_id <- wantedEvId_maybe ct - = ct_ev_id `elemVarSet` co_vars - | otherwise - = False - -- Reason for the partition: - -- see Note [Emitting the residual implication in simplifyInfer] - --- Already done by defaultTyVarsAndSimplify --- ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) - - ; let inner_wanted = wanteds { wc_simple = inner_simple } - ; implics <- if isEmptyWC inner_wanted - then return emptyBag - else do implic1 <- newImplication - return $ unitBag $ - implic1 { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_given_eqs = MaybeGivenEqs - , ic_info = skol_info } - - ; emitConstraints (emptyWC { wc_simple = outer_simple - , wc_impl = implics }) } - where - full_theta = map idType full_theta_vars - skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ] - -- We don't add the quantified variables here, because they are - -- also bound in ic_skols and we want them to be tidied - -- uniformly. - --------------------- -ctsPreds :: Cts -> [PredType] -ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts - , let ev = ctEvidence ct ] - -findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType --- Given a partial type signature f :: (C a, D a, _) => blah --- and the inferred constraints (X a, D a, Y a, C a) --- compute the difference, which is what will fill in the "_" underscore, --- In this case the diff is (X a, Y a). -findInferredDiff annotated_theta inferred_theta - | null annotated_theta -- Short cut the common case when the user didn't - = return inferred_theta -- write any constraints in the partial signature - | otherwise - = pushTcLevelM_ $ - do { lcl_env <- TcM.getLclEnv - ; given_ids <- mapM TcM.newEvVar annotated_theta - ; wanteds <- newWanteds AnnOrigin inferred_theta - ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env - given_cts = mkGivens given_loc given_ids - - ; (residual, _) <- runTcS $ - do { _ <- solveSimpleGivens given_cts - ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } - -- NB: There are no meta tyvars fromn this level annotated_theta - -- because we have either promoted them or unified them - -- See `Note [Quantification and partial signatures]` Wrinkle 2 - - ; return (map (box_pred . ctPred) $ - bagToList $ - wc_simple residual) } - where - box_pred :: PredType -> PredType - box_pred pred = case classifyPredType pred of - EqPred rel ty1 ty2 - | Just (cls,tys) <- boxEqPred rel ty1 ty2 - -> mkClassPred cls tys - | otherwise - -> pprPanic "findInferredDiff" (ppr pred) - _other -> pred - -{- Note [Emitting the residual implication in simplifyInfer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = e -where f's type is inferred to be something like (a, Proxy k (Int |> co)) -and we have an as-yet-unsolved, or perhaps insoluble, constraint - [W] co :: Type ~ k -We can't form types like (forall co. blah), so we can't generalise over -the coercion variable, and hence we can't generalise over things free in -its kind, in the case 'k'. But we can still generalise over 'a'. So -we'll generalise to - f :: forall a. (a, Proxy k (Int |> co)) -Now we do NOT want to form the residual implication constraint - forall a. [W] co :: Type ~ k -because then co's eventual binding (which will be a value binding if we -use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose -type mentions 'co'). Instead, just as we don't generalise over 'co', we -should not bury its constraint inside the implication. Instead, we must -put it outside. - -That is the reason for the partitionBag in emitResidualConstraints, -which takes the CoVars free in the inferred type, and pulls their -constraints out. (NB: this set of CoVars should be closed-over-kinds.) - -All rather subtle; see #14584. - -Note [Add signature contexts as wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#11016): - f2 :: (?x :: Int) => _ - f2 = ?x - -or this - class C a b | a -> b - g :: C p q => p -> q - f3 :: C Int b => _ - f3 = g (3::Int) - -We'll use plan InferGen because there are holes in the type. But: - * For f2 we want to have the (?x :: Int) constraint floating around - so that the functional dependencies kick in. Otherwise the - occurrence of ?x on the RHS produces constraint (?x :: alpha), and - we won't unify alpha:=Int. - - * For f3 want the (C Int b) constraint from the partial signature - to meet the (C Int beta) constraint we get from the call to g; again, - fundeps - -Solution: in simplifyInfer, we add the constraints from the signature -as extra Wanteds. - -Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas -that would mess up (GivenInv) in Note [TcLevel invariants]. Consider - f :: (Eq a, _) => blah1 - f = ....g... - g :: (Eq b, _) => blah2 - g = ...f... - -Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with -TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved -all those constraints. And both have level 1, so we can't put them as -Givens when solving at level 1. - -Best to treat them as Wanteds. - -But see also #20076, which would be solved if they were Givens. - - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [Deciding quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the monomorphism restriction does not apply, then we quantify as follows: - -* Step 1: decideMonoTyVars. - Take the global tyvars, and "grow" them using functional dependencies - E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can - happen because alpha is untouchable here) then do not quantify over - beta, because alpha fixes beta, and beta is effectively free in - the environment too; this logic extends to general fundeps, not - just equalities - - We also account for the monomorphism restriction; if it applies, - add the free vars of all the constraints. - - Result is mono_tvs; we will not quantify over these. - -* Step 2: defaultTyVarsAndSimplify. - Default any non-mono tyvars (i.e ones that are definitely - not going to become further constrained), and re-simplify the - candidate constraints. - - Motivation for re-simplification (#7857): imagine we have a - constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are - not free in the envt, and instance forall (a::*) (b::*). (C a) => C - (a -> b) The instance doesn't match while l1,l2 are polymorphic, but - it will match when we default them to LiftedRep. - - This is all very tiresome. - - This step also promotes the mono_tvs from Step 1. See - Note [Promote monomorphic tyvars]. In fact, the *only* - use of the mono_tvs from Step 1 is to promote them here. - This promotion effectively stops us from quantifying over them - later, in Step 3. Because the actual variables to quantify - over are determined in Step 3 (not in Step 1), it is OK for - the mono_tvs to be missing some variables free in the - environment. This is why removing the psig_qtvs is OK in - decideMonoTyVars. Test case for this scenario: T14479. - -* Step 3: decideQuantifiedTyVars. - Decide which variables to quantify over, as follows: - - - Take the free vars of the partial-type-signature types and constraints, - and the tau-type (zonked_tau_tvs), and then "grow" - them using all the constraints. These are grown_tcvs. - See Note [growThetaTyVars vs closeWrtFunDeps]. - - - Use quantifyTyVars to quantify over the free variables of all the types - involved, but only those in the grown_tcvs. - - Result is qtvs. - -* Step 4: Filter the constraints using pickQuantifiablePreds and the - qtvs. We have to zonk the constraints first, so they "see" the - freshly created skolems. - -Note [Lift equality constraints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't quantify over a constraint (t1 ~# t2) because that isn't a -predicate type; see Note [Types for coercions, predicates, and evidence] -in GHC.Core.TyCo.Rep. - -So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted -to Coercible. - -This tiresome lifting is the reason that pick_me (in -pickQuantifiablePreds) returns a Maybe rather than a Bool. - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, because then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you must quantify over implicit -parameters, *even if* they don't mention the bound type variables. -Reason: because implicit parameters, uniquely, have local instance -declarations. See pickQuantifiablePreds. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -Note [Unconditionally resimplify constraints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke -the solver to simplify the constraints before quantifying them. We do this for -two reasons, enumerated below. We could, in theory, detect when either of these -cases apply and simplify only then, but collecting this information is bothersome, -and simplifying redundantly causes no real harm. Note that this code path -happens only for definitions - * without a type signature - * when -XMonoLocalBinds does not apply - * with unsolved constraints -and so the performance cost will be small. - -1. Defaulting - -Defaulting the variables handled by defaultTyVar may unlock instance simplifications. -Example (typecheck/should_compile/T20584b): - - with (t :: Double) (u :: String) = printf "..." t u - -We know the types of t and u, but we do not know the return type of `with`. So, we -assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is - printf :: PrintfType r => String -> r -The occurrence of printf is instantiated with a fresh var beta. We then get - beta := Double -> String -> alpha -and - [W] PrintfType (Double -> String -> alpha) - -Module Text.Printf exports - instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) -and it looks like that instance should apply. - -But I have elided some key details: (->) is polymorphic over multiplicity and -runtime representation. Here it is in full glory: - [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho)) - instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type)) - -Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance -would have an explicit equality constraint to the left of =>, but that's not what we have.) -Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep. -Yet it's too late to simplify the quantified constraint, and thus GHC infers - wait :: PrintfType (Double -> String -> t) => Double -> String -> t -which is silly. Simplifying again after defaulting solves this problem. - -2. Interacting functional dependencies - -Suppose we have - - class C a b | a -> b - -and we are running simplifyInfer over - - forall[2] x. () => [W] C a beta1[1] - forall[2] y. () => [W] C a beta2[1] - -These are two implication constraints, both of which contain a -wanted for the class C. Neither constraint mentions the bound -skolem. We might imagine that these constraint could thus float -out of their implications and then interact, causing beta1 to unify -with beta2, but constraints do not currently float out of implications. - -Unifying the beta1 and beta2 is important. Without doing so, then we might -infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the -ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as -required by the fundep interactions. This happens in the parsec library, and -in test case typecheck/should_compile/FloatFDs. - -If we re-simplify, however, the two fundep constraints will interact, causing -a unification between beta1 and beta2, and all will be well. The key step -is that this simplification happens *after* the call to approximateWC in -simplifyInfer. - -Note [Do not quantify over constraints that determine a variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (typecheck/should_compile/tc231), where we're trying to infer -the type of a top-level declaration. We have - class Zork s a b | a -> b -and the candidate constraint at the end of simplifyInfer is - [W] Zork alpha (Z [Char]) beta -We definitely do want to quantify over alpha (which is mentioned in -the tau-type). But we do *not* want to quantify over beta: it is -determined by the functional dependency on Zork: note that the second -argument to Zork in the Wanted is a variable-free Z [Char]. - -The question here: do we want to quantify over the constraint? Definitely not. -Since we're not quantifying over beta, GHC has no choice but to zap beta -to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no. - -The no_fixed_dependencies check in pickQuantifiablePreds eliminates this -candidate from the pool. Because there are no Zork instances in scope, this -program is rejected. - --} - -decideQuantification - :: SkolemInfo - -> InferMode - -> TcLevel - -> [(Name, TcTauType)] -- Variables to be generalised - -> [TcIdSigInst] -- Partial type signatures (if any) - -> [PredType] -- Candidate theta; already zonked - -> TcM ( [TcTyVar] -- Quantify over these (skolems) - , [PredType] -- and this context (fully zonked) - , CoVarSet) --- See Note [Deciding quantification] -decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates - = do { -- Step 1: find the mono_tvs - ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode - name_taus psigs candidates - - -- Step 2: default any non-mono tyvars, and re-simplify - -- This step may do some unification, but result candidates is zonked - ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - - -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates - - -- Step 4: choose which of the remaining candidate - -- predicates to actually quantify over - -- NB: decideQuantifiedTyVars turned some meta tyvars - -- into quantified skolems, so we have to zonk again - ; candidates <- TcM.zonkTcTypes candidates - ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) - ; let min_theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - pickQuantifiablePreds (mkVarSet qtvs) candidates - - min_psig_theta = mkMinimalBySCs id psig_theta - - -- Add psig_theta back in here, even though it's already - -- part of candidates, because we always want to quantify over - -- psig_theta, and pickQuantifiableCandidates might have - -- dropped some e.g. CallStack constraints. c.f #14658 - -- equalities (a ~ Bool) - -- It's helpful to use the same "find difference" algorithm here as - -- we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) - -- See Note [Constraints in partial type signatures] - ; theta <- if null psig_theta - then return min_theta -- Fast path for the non-partial-sig case - else do { diff <- findInferredDiff min_psig_theta min_theta - ; return (min_psig_theta ++ diff) } - - ; traceTc "decideQuantification" - (vcat [ text "infer_mode:" <+> ppr infer_mode - , text "candidates:" <+> ppr candidates - , text "psig_theta:" <+> ppr psig_theta - , text "mono_tvs:" <+> ppr mono_tvs - , text "co_vars:" <+> ppr co_vars - , text "qtvs:" <+> ppr qtvs - , text "theta:" <+> ppr theta ]) - ; return (qtvs, theta, co_vars) } - -{- Note [Constraints in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a partial type signature - f :: (Eq a, C a, _) => blah - -We will ultimately quantify f over (Eq a, C a, ), where - - * is the result of - findInferredDiff (Eq a, C a) - in GHC.Tc.Gen.Bind.chooseInferredQuantifiers - - * is the theta returned right here, - by decideQuantification - -At least for single functions we would like to quantify f over -precisely the same theta as , so that we get to take -the short-cut path in GHC.Tc.Gen.Bind.mkExport, and avoid calling -tcSubTypeSigma for impedance matching. Why avoid? Because it falls -over for ambiguous types (#20921). - -We can get precisely the same theta by using the same algorithm, -findInferredDiff. - -All of this goes wrong if we have (a) mutual recursion, (b) multiple -partial type signatures, (c) with different constraints, and (d) -ambiguous types. Something like - f :: forall a. Eq a => F a -> _ - f x = (undefined :: a) == g x undefined - g :: forall b. Show b => F b -> _ -> b - g x y = let _ = (f y, show x) in x -But that's a battle for another day. --} - -decideMonoTyVars :: InferMode - -> [(Name,TcType)] - -> [TcIdSigInst] - -> [PredType] - -> TcM (TcTyCoVarSet, [PredType], CoVarSet) --- Decide which tyvars and covars cannot be generalised: --- (a) Free in the environment --- (b) Mentioned in a constraint we can't generalise --- (c) Connected by an equality or fundep to (a) or (b) --- Also return CoVars that appear free in the final quantified types --- we can't quantify over these, and we must make sure they are in scope -decideMonoTyVars infer_mode name_taus psigs candidates - = do { (no_quant, maybe_quant) <- pick infer_mode candidates - - -- 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 <- zonkTcTyVarsToTcTyVars $ binderVars $ - concatMap (map snd . sig_inst_skols) psigs - - ; psig_theta <- mapM TcM.zonkTcType $ - concatMap sig_inst_theta psigs - - ; taus <- mapM (TcM.zonkTcType . snd) name_taus - - ; tc_lvl <- TcM.getTcLevel - ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta - - co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates) - co_var_tvs = closeOverKinds co_vars - -- The co_var_tvs are tvs mentioned in the types of covars or - -- coercion holes. We can't quantify over these covars, so we - -- must include the variable in their types in the mono_tvs. - -- E.g. If we can't quantify over co :: k~Type, then we can't - -- quantify over k either! Hence closeOverKinds - - mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ - tyCoVarsOfTypes candidates - -- We need to grab all the non-quantifiable tyvars in the - -- types so that we can grow this set to find other - -- non-quantifiable tyvars. This can happen with something - -- like - -- f x y = ... - -- where z = x 3 - -- The body of z tries to unify the type of x (call it alpha[1]) - -- with (beta[2] -> gamma[2]). This unification fails because - -- alpha is untouchable. But we need to know not to quantify over - -- beta or gamma, because they are in the equality constraint with - -- alpha. Actual test case: typecheck/should_compile/tc213 - - mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs - -- mono_tvs1 is now the set of variables from an outer scope - -- (that's mono_tvs0) and the set of covars, closed over kinds. - -- Given this set of variables we know we will not quantify, - -- we want to find any other variables that are determined by this - -- set, by functional dependencies or equalities. We thus use - -- closeWrtFunDeps to find all further variables determined by this root - -- set. See Note [growThetaTyVars vs closeWrtFunDeps] - - non_ip_candidates = filterOut isIPLikePred candidates - -- implicit params don't really determine a type variable - -- (that is, we might have IP "c" Bool and IP "c" Int in different - -- places within the same program), and - -- skipping this causes implicit params to monomorphise too many - -- variables; see Note [Inheriting implicit parameters] in - -- GHC.Tc.Solver. Skipping causes typecheck/should_compile/tc219 - -- to fail. - - mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1 - -- mono_tvs2 now contains any variable determined by the "root - -- set" of monomorphic tyvars in mono_tvs1. - - constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ - closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant) - `minusVarSet` mono_tvs2 - -- constrained_tvs: the tyvars that we are not going to - -- quantify solely because of the monomorphism restriction - -- - -- (`minusVarSet` mono_tvs2): a type variable is only - -- "constrained" (so that the MR bites) if it is not - -- free in the environment (#13785) or is determined - -- by some variable that is free in the env't - - mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs) - `delVarSetList` psig_qtvs - -- (`delVarSetList` psig_qtvs): if the user has explicitly - -- asked for quantification, then that request "wins" - -- over the MR. - -- - -- What if a psig variable is also free in the environment - -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation - -- in Step 2 of Note [Deciding quantification]. - - -- Warn about the monomorphism restriction - ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do - let dia = TcRnMonomorphicBindings (map fst name_taus) - diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia - - ; traceTc "decideMonoTyVars" $ vcat - [ text "infer_mode =" <+> ppr infer_mode - , text "mono_tvs0 =" <+> ppr mono_tvs0 - , text "no_quant =" <+> ppr no_quant - , text "maybe_quant =" <+> ppr maybe_quant - , text "mono_tvs =" <+> ppr mono_tvs - , text "co_vars =" <+> ppr co_vars ] - - ; return (mono_tvs, maybe_quant, co_vars) } - where - pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) - -- Split the candidates into ones we definitely - -- won't quantify, and ones that we might - pick NoRestrictions cand = return ([], cand) - pick ApplyMR cand = return (cand, []) - pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } - - -- For EagerDefaulting, do not quantify over - -- over any interactive class constraint - is_int_ct ovl_strings pred - | Just (cls, _) <- getClassPredTys_maybe pred - = isInteractiveClass ovl_strings cls - | otherwise - = False - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet -- Promote these mono-tyvars - -> [PredType] -- Assumed zonked - -> TcM [PredType] -- Guaranteed zonked --- Promote the known-monomorphic tyvars; --- Default any tyvar free in the constraints; --- and re-simplify in case the defaulting allows further simplification -defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - = do { -- Promote any tyvars that we cannot generalise - -- See Note [Promote monomorphic tyvars] - ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) - ; _ <- promoteTyVarSet mono_tvs - - -- Default any kind/levity vars - ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - <- candidateQTyVarsOfTypes candidates - -- any covars should already be handled by - -- the logic in decideMonoTyVars, which looks at - -- the constraints generated - - ; poly_kinds <- xoptM LangExt.PolyKinds - ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs) - ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - - ; simplify_cand candidates - } - where - default_one poly_kinds is_kind_var tv - | not (isMetaTyVar tv) - = return () - | tv `elemVarSet` mono_tvs - = return () - | otherwise - = void $ defaultTyVar - (if not poly_kinds && is_kind_var - then DefaultKindVars - else NonStandardDefaulting DefaultNonStandardTyVars) - -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable. - tv - - -- this common case (no inferred constraints) should be fast - simplify_cand [] = return [] - -- see Note [Unconditionally resimplify constraints when quantifying] - simplify_cand candidates - = do { clone_wanteds <- newWanteds DefaultOrigin candidates - ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ - simplifyWantedsTcM clone_wanteds - -- Discard evidence; simples is fully zonked - - ; let new_candidates = ctsPreds simples - ; traceTc "Simplified after defaulting" $ - vcat [ text "Before:" <+> ppr candidates - , text "After:" <+> ppr new_candidates ] - ; return new_candidates } - ------------------- -decideQuantifiedTyVars - :: SkolemInfo - -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs - -> [TcIdSigInst] -- Partial signatures - -> [PredType] -- Candidates, zonked - -> TcM [TyVar] --- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars skol_info name_taus psigs candidates - = do { -- Why psig_tys? We try to quantify over everything free in here - -- See Note [Quantification and partial signatures] - -- Wrinkles 2 and 3 - ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,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 - - ; let -- Try to quantify over variables free in these types - psig_tys = psig_tv_tys ++ psig_theta - seed_tys = psig_tys ++ tau_tys - - -- Now "grow" those seeds to find ones reachable via 'candidates' - -- See Note [growThetaTyVars vs closeWrtFunDeps] - grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) - - -- Now we have to classify them into kind variables and type variables - -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars - -- - -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces - -- them in that order, so that the final qtvs quantifies in the same - -- order as the partial signatures do (#13524) - ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ - psig_tys ++ candidates ++ tau_tys - ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) - dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } - - ; traceTc "decideQuantifiedTyVars" (vcat - [ text "tau_tys =" <+> ppr tau_tys - , text "candidates =" <+> ppr candidates - , text "cand_kvs =" <+> ppr cand_kvs - , text "cand_tvs =" <+> ppr cand_tvs - , text "tau_tys =" <+> ppr tau_tys - , text "seed_tys =" <+> ppr seed_tys - , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) - , text "grown_tcvs =" <+> ppr grown_tcvs - , text "dvs =" <+> ppr dvs_plus]) - - ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } - ------------------- --- | When inferring types, should we quantify over a given predicate? --- Generally true of classes; generally false of equality constraints. --- Equality constraints that mention quantified type variables and --- implicit variables complicate the story. See Notes --- [Inheriting implicit parameters] and [Quantifying over equality constraints] -pickQuantifiablePreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- This function decides whether a particular constraint should be --- quantified over, given the type variables that are being quantified -pickQuantifiablePreds qtvs theta - = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without - -- -XFlexibleContexts: see #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - mapMaybe (pick_me flex_ctxt) theta - where - pick_me flex_ctxt pred - = case classifyPredType pred of - - ClassPred cls tys - | Just {} <- isCallStackPred cls tys - -- NEVER infer a CallStack constraint. Otherwise we let - -- the constraints bubble up to be solved from the outer - -- context, or be defaulted when we reach the top-level. - -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -> Nothing - - | isIPClass cls - -> Just pred -- See Note [Inheriting implicit parameters] - - | pick_cls_pred flex_ctxt cls tys - -> Just pred - - EqPred eq_rel ty1 ty2 - | quantify_equality eq_rel ty1 ty2 - , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constraints when quantifying] - , pick_cls_pred flex_ctxt cls tys - -> Just (mkClassPred cls tys) - - IrredPred ty - | tyCoVarsOfType ty `intersectsVarSet` qtvs - -> Just pred - - _ -> Nothing - - - pick_cls_pred flex_ctxt cls tys - = tyCoVarsOfTypes tys `intersectsVarSet` qtvs - && (checkValidClsArgs flex_ctxt cls tys) - -- Only quantify over predicates that checkValidType - -- will pass! See #10351. - && (no_fixed_dependencies cls tys) - - -- See Note [Do not quantify over constraints that determine a variable] - no_fixed_dependencies cls tys - = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys - | fd <- cls_fds - , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ] - where - (cls_tvs, cls_fds) = classTvsFds cls - - -- See Note [Quantifying over equality constraints] - quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 - quantify_equality ReprEq _ _ = True - - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False - - ------------------- -growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet --- See Note [growThetaTyVars vs closeWrtFunDeps] -growThetaTyVars theta tcvs - | null theta = tcvs - | otherwise = transCloVarSet mk_next seed_tcvs - where - seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPLikePred theta - -- See Note [Inheriting implicit parameters] - - mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones - mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips - grow_one so_far pred tcvs - | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs - | otherwise = tcvs - where - pred_tcvs = tyCoVarsOfType pred - - -{- Note [Promote monomorphic tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promote any type variables that are free in the environment. Eg - f :: forall qtvs. bound_theta => zonked_tau -The free vars of f's type become free in the envt, and hence will show -up whenever 'f' is called. They may currently at rhs_tclvl, but they -had better be unifiable at the outer_tclvl! Example: envt mentions -alpha[1] - tau_ty = beta[2] -> beta[2] - constraints = alpha ~ [beta] -we don't quantify over beta (since it is fixed by envt) -so we must promote it! The inferred type is just - f :: beta -> beta - -NB: promoteTyVarSet ignores coercion variables - -Note [Quantification and partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When choosing type variables to quantify, the basic plan is to -quantify over all type variables that are - * free in the tau_tvs, and - * not forced to be monomorphic (mono_tvs), - for example by being free in the environment. - -However, in the case of a partial type signature, we are doing inference -*in the presence of a type signature*. For example: - f :: _ -> a - f x = ... -or - g :: (Eq _a) => _b -> _b -In both cases we use plan InferGen, and hence call simplifyInfer. But -those 'a' variables are skolems (actually TyVarTvs), and we should be -sure to quantify over them. This leads to several wrinkles: - -* Wrinkle 1. In the case of a type error - f :: _ -> Maybe a - f x = True && x - The inferred type of 'f' is f :: Bool -> Bool, but there's a - left-over error of form (Maybe a ~ Bool). The error-reporting - machine expects to find a binding site for the skolem 'a', so we - add it to the quantified tyvars. - -* Wrinkle 2. Consider the partial type signature - f :: (Eq _) => Int -> Int - f x = x - In normal cases that makes sense; e.g. - g :: Eq _a => _a -> _a - g x = x - where the signature makes the type less general than it could - be. But for 'f' we must therefore quantify over the user-annotated - constraints, to get - f :: forall a. Eq a => Int -> Int - (thereby correctly triggering an ambiguity error later). If we don't - we'll end up with a strange open type - f :: Eq alpha => Int -> Int - which isn't ambiguous but is still very wrong. - - Bottom line: Try to quantify over any variable free in psig_theta, - just like the tau-part of the type. - -* Wrinkle 3 (#13482). Also consider - f :: forall a. _ => Int -> Int - f x = if (undefined :: a) == undefined then x else 0 - Here we get an (Eq a) constraint, but it's not mentioned in the - psig_theta nor the type of 'f'. But we still want to quantify - over 'a' even if the monomorphism restriction is on. - -* Wrinkle 4 (#14479) - foo :: Num a => a -> a - foo xxx = g xxx - where - g :: forall b. Num b => _ -> b - g y = xxx + y - - In the signature for 'g', we cannot quantify over 'b' because it turns out to - get unified with 'a', which is free in g's environment. So we carefully - refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars. We - report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. - -Note [growThetaTyVars vs closeWrtFunDeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with -the same type and similar behavior. This Note outlines the differences -and why we use one or the other. - -Both functions take a list of constraints. We will call these the -*candidates*. - -closeWrtFunDeps takes a set of "determined" type variables and finds the -closure of that set with respect to the functional dependencies -within the class constraints in the set of candidates. So, if we -have - - class C a b | a -> b - class D a b -- no fundep - candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)} - -then closeWrtFunDeps {a} will return the set {a,b,c}. -This is because, if `a` is determined, then `b` and `c` are, too, -by functional dependency. closeWrtFunDeps called with any seed set not including -`a` will just return its argument, as only `a` determines any other -type variable (in this example). - -growThetaTyVars operates similarly, but it behaves as if every -constraint has a functional dependency among all its arguments. -So, continuing our example, growThetaTyVars {a} will return -{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of -variables to include all variables that are mentioned in the same -constraint (transitively). - -We use closeWrtFunDeps in places where we need to know which variables are -*always* determined by some seed set. This includes - * when determining the mono-tyvars in decideMonoTyVars. If `a` - is going to be monomorphic, we need b and c to be also: they - are determined by the choice for `a`. - * when checking instance coverage, in - GHC.Tc.Instance.FunDeps.checkInstCoverage - -On the other hand, we use growThetaTyVars where we need to know -which variables *might* be determined by some seed set. This includes - * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers - and decideQuantifiedTyVars -How can `a` determine (say) `d` in the example above without a fundep? -Suppose we have - instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c) -Now, if `a` turns out to be a list, it really does determine b and c. -The danger in overdoing quantification is the creation of an ambiguous -type signature, but this is conveniently caught in the validity checker. - -Note [Quantification with errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find that the RHS of the definition has some absolutely-insoluble -constraints (including especially "variable not in scope"), we - -* Abandon all attempts to find a context to quantify over, - and instead make the function fully-polymorphic in whatever - type we have found - -* Return a flag from simplifyInfer, indicating that we found an - insoluble constraint. This flag is used to suppress the ambiguity - check for the inferred type, which may well be bogus, and which - tends to obscure the real error. This fix feels a bit clunky, - but I failed to come up with anything better. - -Reasons: - - Avoid downstream errors - - Do not perform an ambiguity test on a bogus type, which might well - fail spuriously, thereby obfuscating the original insoluble error. - #14000 is an example - -I tried an alternative approach: simply failM, after emitting the -residual implication constraint; the exception will be caught in -GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type -(forall a. a). But that didn't work with -fdefer-type-errors, because -the recovery from failM emits no code at all, so there is no function -to run! But -fdefer-type-errors aspires to produce a runnable program. - -Note [Default while Inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our current plan is that defaulting only happens at simplifyTop and -not simplifyInfer. This may lead to some insoluble deferred constraints. -Example: - -instance D g => C g Int b - -constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha -type inferred = gamma -> gamma - -Now, if we try to default (alpha := Int) we will be able to refine the implication to - (forall b. 0 => C gamma Int b) -which can then be simplified further to - (forall b. 0 => D gamma) -Finally, we /can/ approximate this implication with (D gamma) and infer the quantified -type: forall g. D g => g -> g - -Instead what will currently happen is that we will get a quantified type -(forall g. g -> g) and an implication: - forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha - -Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an -unsolvable implication: - forall g. 0 => (forall b. 0 => D g) - -The concrete example would be: - h :: C g a s => g -> a -> ST s a - f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) - -But it is quite tedious to do defaulting and resolve the implication constraints, and -we have not observed code breaking because of the lack of defaulting in inference, so -we don't do it for now. - - - -Note [Minimize by Superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we quantify over a constraint, in simplifyInfer we need to -quantify over a constraint that is minimal in some sense: For -instance, if the final wanted constraint is (Eq alpha, Ord alpha), -we'd like to quantify over Ord alpha, because we can just get Eq alpha -from superclass selection from Ord alpha. This minimization is what -mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint -to check the original wanted. - - -Note [Avoid unnecessary constraint simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -------- NB NB NB (Jun 12) ------------- - This note not longer applies; see the notes with #4361. - But I'm leaving it in here so we remember the issue.) - ---------------------------------------- -When inferring the type of a let-binding, with simplifyInfer, -try to avoid unnecessarily simplifying class constraints. -Doing so aids sharing, but it also helps with delicate -situations like - - instance C t => C [t] where .. - - f :: C [t] => .... - f x = let g y = ...(constraint C [t])... - in ... -When inferring a type for 'g', we don't want to apply the -instance decl, because then we can't satisfy (C t). So we -just notice that g isn't quantified over 't' and partition -the constraints before simplifying. - -This only half-works, but then let-generalisation only half-works. - -********************************************************************************* -* * -* Main Simplifier * -* * -*********************************************************************************** - --} - -simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints --- Solve the specified Wanted constraints --- Discard the evidence binds --- Postcondition: fully zonked -simplifyWantedsTcM wanted - = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) - ; result <- TcM.zonkWC result - ; traceTc "simplifyWantedsTcM }" (ppr result) - ; return result } - -solveWanteds :: WantedConstraints -> TcS WantedConstraints -solveWanteds wc@(WC { wc_errors = errs }) - = do { cur_lvl <- TcS.getTcLevel - ; traceTcS "solveWanteds {" $ - vcat [ text "Level =" <+> ppr cur_lvl - , ppr wc ] - - ; dflags <- getDynFlags - ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc - - ; errs' <- simplifyDelayedErrors errs - ; let final_wc = solved_wc { wc_errors = errs' } - - ; ev_binds_var <- getTcEvBindsVar - ; bb <- TcS.getTcEvBindsMap ev_binds_var - ; traceTcS "solveWanteds }" $ - vcat [ text "final wc =" <+> ppr final_wc - , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] - - ; return final_wc } - -simplify_loop :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints --- Do a round of solving, and call maybe_simplify_again to iterate --- The 'definitely_redo_implications' flags is False if the only reason we --- are iterating is that we have added some new Wanted superclasses --- hoping for fundeps to help us; see Note [Superclass iteration] --- --- Does not affect wc_holes at all; reason: wc_holes never affects anything --- else, so we do them once, at the end in solveWanteds -simplify_loop n limit definitely_redo_implications - wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { csTraceTcS $ - text "simplify_loop iteration=" <> int n - <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma - , int (lengthBag simples) <+> text "simples to solve" ]) - ; traceTcS "simplify_loop: wc =" (ppr wc) - - ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration] - solveSimpleWanteds simples - -- Any insoluble constraints are in 'simples' and so get rewritten - -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet - - ; wc2 <- if not definitely_redo_implications -- See Note [Superclass iteration] - && unifs1 == 0 -- for this conditional - && isEmptyBag (wc_impl wc1) - then return (wc { wc_simple = wc_simple wc1 }) -- Short cut - else do { implics2 <- solveNestedImplications $ - implics `unionBags` (wc_impl wc1) - ; return (wc { wc_simple = wc_simple wc1 - , wc_impl = implics2 }) } - - ; unif_happened <- resetUnificationFlag - ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened - -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad - ; maybe_simplify_again (n+1) limit unif_happened wc2 } - -maybe_simplify_again :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints -maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) - | n `intGtLimit` limit - = do { -- Add an error (not a warning) if we blow the limit, - -- Typically if we blow the limit we are going to report some other error - -- (an unsolved constraint), and we don't want that error to suppress - -- the iteration limit warning! - addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc - ; return wc } - - | unif_happened - = simplify_loop n limit True wc - - | superClassesMightHelp wc - = -- We still have unsolved goals, and apparently no way to solve them, - -- so try expanding superclasses at this level, both Given and Wanted - do { pending_given <- getPendingGivenScs - ; let (pending_wanted, simples1) = getPendingWantedScs simples - ; if null pending_given && null pending_wanted - then return wc -- After all, superclasses did not help - else - do { new_given <- makeSuperClasses pending_given - ; new_wanted <- makeSuperClasses pending_wanted - ; solveSimpleGivens new_given -- Add the new Givens to the inert set - ; simplify_loop n limit (not (null pending_given)) $ - wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } - -- (not (null pending_given)): see Note [Superclass iteration] - - | otherwise - = return wc - -{- Note [Superclass iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this implication constraint - forall a. - [W] d: C Int beta - forall b. blah -where - class D a b | a -> b - class D a b => C a b -We will expand d's superclasses, giving [W] D Int beta, in the hope of geting -fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), -and if so it seems a pity to waste time iterating the implications (forall b. blah) -(If we add new Given superclasses it's a different matter: it's really worth looking -at the implications.) - -Hence the definitely_redo_implications flag to simplify_loop. It's usually -True, but False in the case where the only reason to iterate is new Wanted -superclasses. In that case we check whether the new Wanteds actually led to -any new unifications, and iterate the implications only if so. --} - -solveNestedImplications :: Bag Implication - -> TcS (Bag Implication) --- Precondition: the TcS inerts may contain unsolved simples which have --- to be converted to givens before we go inside a nested implication. -solveNestedImplications implics - | isEmptyBag implics - = return (emptyBag) - | otherwise - = do { traceTcS "solveNestedImplications starting {" empty - ; unsolved_implics <- mapBagM solveImplication implics - - -- ... and we are back in the original TcS inerts - -- Notice that the original includes the _insoluble_simples so it was safe to ignore - -- them in the beginning of this function. - ; traceTcS "solveNestedImplications end }" $ - vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ] - - ; return (catBagMaybes unsolved_implics) } - -solveImplication :: Implication -- Wanted - -> TcS (Maybe Implication) -- Simplified implication (empty or singleton) --- Precondition: The TcS monad contains an empty worklist and given-only inerts --- which after trying to solve this implication we must restore to their original value -solveImplication imp@(Implic { ic_tclvl = tclvl - , ic_binds = ev_binds_var - , ic_given = given_ids - , ic_wanted = wanteds - , ic_info = info - , ic_status = status }) - | isSolvedStatus status - = return (Just imp) -- Do nothing - - | otherwise -- Even for IC_Insoluble it is worth doing more work - -- The insoluble stuff might be in one sub-implication - -- and other unsolved goals in another; and we want to - -- solve the latter as much as possible - = do { inerts <- getTcSInerts - ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) - - -- commented out; see `where` clause below - -- ; when debugIsOn check_tc_level - - -- Solve the nested constraints - ; (has_given_eqs, given_insols, residual_wanted) - <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info (ic_env imp) - givens = mkGivens loc given_ids - ; solveSimpleGivens givens - - ; residual_wanted <- solveWanteds wanteds - - ; (has_eqs, given_insols) <- getHasGivenEqs tclvl - -- Call getHasGivenEqs /after/ solveWanteds, because - -- solveWanteds can augment the givens, via expandSuperClasses, - -- to reveal given superclass equalities - - ; return (has_eqs, given_insols, residual_wanted) } - - ; traceTcS "solveImplication 2" - (ppr given_insols $$ ppr residual_wanted) - ; let final_wanted = residual_wanted `addInsols` given_insols - -- Don't lose track of the insoluble givens, - -- which signal unreachable code; put them in ic_wanted - - ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs - , ic_wanted = final_wanted }) - - ; evbinds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; traceTcS "solveImplication end }" $ vcat - [ text "has_given_eqs =" <+> ppr has_given_eqs - , text "res_implic =" <+> ppr res_implic - , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) - , text "implication tvcs =" <+> ppr tcvs ] - - ; return res_implic } - - -- TcLevels must be strictly increasing (see (ImplicInv) in - -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType), - -- and in fact I think they should always increase one level at a time. - - -- Though sensible, this check causes lots of testsuite failures. It is - -- remaining commented out for now. - {- - check_tc_level = do { cur_lvl <- TcS.getTcLevel - ; massertPpr (tclvl == pushTcLevel cur_lvl) - (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) } - -} - ----------------------- -setImplicationStatus :: Implication -> TcS (Maybe Implication) --- Finalise the implication returned from solveImplication, --- setting the ic_status field --- Precondition: the ic_status field is not already IC_Solved --- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_status = status - , ic_info = info - , ic_wanted = wc - , ic_given = givens }) - | assertPpr (not (isSolvedStatus status)) (ppr info) $ - -- Precondition: we only set the status if it is not already solved - not (isSolvedWC pruned_wc) - = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) - - ; implic <- neededEvVars implic - - ; let new_status | insolubleWC pruned_wc = IC_Insoluble - | otherwise = IC_Unsolved - new_implic = implic { ic_status = new_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) - - ; return $ Just new_implic } - - | otherwise -- Everything is solved - -- Set status to IC_Solved, - -- and compute the dead givens and outer needs - -- See Note [Tracking redundant constraints] - = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) - - ; implic@(Implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) <- neededEvVars implic - - ; bad_telescope <- checkBadTelescope implic - - ; let warn_givens = findUnnecessaryGivens info need_inner givens - - discard_entire_implication -- Can we discard the entire implication? - = null warn_givens -- No warning from this implication - && not bad_telescope - && isEmptyWC pruned_wc -- No live children - && isEmptyVarSet need_outer -- No needed vars to pass up to parent - - final_status - | bad_telescope = IC_BadTelescope - | otherwise = IC_Solved { ics_dead = warn_givens } - final_implic = implic { ic_status = final_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(all-solved) }" $ - vcat [ text "discard:" <+> ppr discard_entire_implication - , text "new_implic:" <+> ppr final_implic ] - - ; return $ if discard_entire_implication - then Nothing - else Just final_implic } - where - WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc - - pruned_implics = filterBag keep_me implics - pruned_wc = WC { wc_simple = simples - , wc_impl = pruned_implics - , wc_errors = errs } -- do not prune holes; these should be reported - - keep_me :: Implication -> Bool - keep_me ic - | IC_Solved { ics_dead = dead_givens } <- ic_status ic - -- Fully solved - , null dead_givens -- No redundant givens to report - , isEmptyBag (wc_impl (ic_wanted ic)) - -- And no children that might have things to report - = False -- Tnen we don't need to keep it - | otherwise - = True -- Otherwise, keep it - -findUnnecessaryGivens :: SkolemInfoAnon -> VarSet -> [EvVar] -> [EvVar] -findUnnecessaryGivens info need_inner givens - | not (warnRedundantGivens info) -- Don't report redundant constraints at all - = [] - - | not (null unused_givens) -- Some givens are literally unused - = unused_givens - - | otherwise -- All givens are used, but some might - = redundant_givens -- still be redundant e.g. (Eq a, Ord a) - - where - in_instance_decl = case info of { InstSkol {} -> True; _ -> False } - -- See Note [Redundant constraints in instance decls] - - unused_givens = filterOut is_used givens - - is_used given = is_type_error given - || (given `elemVarSet` need_inner) - || (in_instance_decl && is_improving (idType given)) - - minimal_givens = mkMinimalBySCs evVarPred givens - is_minimal = (`elemVarSet` mkVarSet minimal_givens) - redundant_givens - | in_instance_decl = [] - | otherwise = filterOut is_minimal givens - - -- See #15232 - is_type_error = isJust . userTypeError_maybe . idType - - is_improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instance declarations are special in two ways: - -* We don't report unused givens if they can give rise to improvement. - Example (#10100): - class Add a b ab | a b -> ab, a ab -> b - instance Add Zero b b - instance Add a b ab => Add (Succ a) b (Succ ab) - The context (Add a b ab) for the instance is clearly unused in terms - of evidence, since the dictionary has no fields. But it is still - needed! With the context, a wanted constraint - Add (Succ Zero) beta (Succ Zero) - we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. - But without the context we won't find beta := Zero. - - This only matters in instance declarations. - -* We don't report givens that are a superclass of another given. E.g. - class Ord r => UserOfRegs r a where ... - instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - The (Ord r) is not redundant, even though it is a superclass of - (UserOfRegs r CmmReg). See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. - - Again this is specific to instance declarations. --} - - -checkBadTelescope :: Implication -> TcS Bool --- True <=> the skolems form a bad telescope --- See Note [Checking telescopes] in GHC.Tc.Types.Constraint -checkBadTelescope (Implic { ic_info = info - , ic_skols = skols }) - | checkTelescopeSkol info - = do{ skols <- mapM TcS.zonkTyCoVarKind skols - ; return (go emptyVarSet (reverse skols))} - - | otherwise - = return False - - where - go :: TyVarSet -- skolems that appear *later* than the current ones - -> [TcTyVar] -- ordered skolems, in reverse order - -> Bool -- True <=> there is an out-of-order skolem - go _ [] = False - go later_skols (one_skol : earlier_skols) - | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols - = True - | otherwise - = go (later_skols `extendVarSet` one_skol) earlier_skols - -warnRedundantGivens :: SkolemInfoAnon -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ rrc -> reportRedundantConstraints rrc - ExprSigCtxt rrc -> reportRedundantConstraints rrc - _ -> False - - -- To think about: do we want to report redundant givens for - -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. -warnRedundantGivens (InstSkol {}) = True -warnRedundantGivens _ = False - -neededEvVars :: Implication -> TcS Implication --- Find all the evidence variables that are "needed", --- and delete dead evidence bindings --- See Note [Tracking redundant constraints] --- See Note [Delete dead Given evidence bindings] --- --- - Start from initial_seeds (from nested implications) --- --- - Add free vars of RHS of all Wanted evidence bindings --- and coercion variables accumulated in tcvs (all Wanted) --- --- - Generate 'needed', the needed set of EvVars, by doing transitive --- closure through Given bindings --- e.g. Needed {a,b} --- Given a = sc_sel a2 --- Then a2 is needed too --- --- - Prune out all Given bindings that are not needed --- --- - From the 'needed' set, delete ev_bndrs, the binders of the --- evidence bindings, to give the final needed variables --- -neededEvVars implic@(Implic { ic_given = givens - , ic_binds = ev_binds_var - , ic_wanted = WC { wc_impl = implics } - , ic_need_inner = old_needs }) - = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - - ; let seeds1 = foldr add_implic_seeds old_needs implics - 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 = varSetMinusEvBindMap need_inner live_ev_binds - `delVarSetList` givens - - ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds - -- See Note [Delete dead Given evidence bindings] - - ; traceTcS "neededEvVars" $ - vcat [ text "old_needs:" <+> ppr old_needs - , text "seeds3:" <+> ppr seeds3 - , text "tcvs:" <+> ppr tcvs - , text "ev_binds:" <+> ppr ev_binds - , text "live_ev_binds:" <+> ppr live_ev_binds ] - - ; return (implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) } - where - add_implic_seeds (Implic { ic_need_outer = needs }) acc - = needs `unionVarSet` acc - - needed_ev_bind needed (EvBind { eb_lhs = ev_var - , eb_is_given = is_given }) - | is_given = ev_var `elemVarSet` needed - | otherwise = True -- Keep all wanted bindings - - 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 - -------------------------------------------------- -simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError) -simplifyDelayedErrors = mapBagM simpl_err - where - simpl_err :: DelayedError -> TcS DelayedError - simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole - simpl_err err@(DE_NotConcrete {}) = return err - - simpl_hole :: Hole -> TcS Hole - - -- See Note [Do not simplify ConstraintHoles] - simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h - - -- other wildcards should be simplified for printing - -- we must do so here, and not in the error-message generation - -- code, because we have all the givens already set up - simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) - = do { ty' <- rewriteType loc ty - ; return (h { hole_ty = ty' }) } - -{- Note [Delete dead Given evidence bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a result of superclass expansion, we speculatively -generate evidence bindings for Givens. E.g. - f :: (a ~ b) => a -> b -> Bool - f x y = ... -We'll have - [G] d1 :: (a~b) -and we'll speculatively generate the evidence binding - [G] d2 :: (a ~# b) = sc_sel d - -Now d2 is available for solving. But it may not be needed! Usually -such dead superclass selections will eventually be dropped as dead -code, but: - - * It won't always be dropped (#13032). In the case of an - unlifted-equality superclass like d2 above, we generate - case heq_sc d1 of d2 -> ... - and we can't (in general) drop that case expression in case - d1 is bottom. So it's technically unsound to have added it - in the first place. - - * Simply generating all those extra superclasses can generate lots of - code that has to be zonked, only to be discarded later. Better not - to generate it in the first place. - - Moreover, if we simplify this implication more than once - (e.g. because we can't solve it completely on the first iteration - of simpl_loop), we'll generate all the same bindings AGAIN! - -Easy solution: take advantage of the work we are doing to track dead -(unused) Givens, and use it to prune the Given bindings too. This is -all done by neededEvVars. - -This led to a remarkable 25% overall compiler allocation decrease in -test T12227. - -But we don't get to discard all redundant equality superclasses, alas; -see #15205. - -Note [Do not simplify ConstraintHoles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before printing the inferred value for a type hole (a _ wildcard in -a partial type signature), we simplify it w.r.t. any Givens. This -makes for an easier-to-understand diagnostic for the user. - -However, we do not wish to do this for extra-constraint holes. Here is -the example for why (partial-sigs/should_compile/T12844): - - bar :: _ => FooData rngs - bar = foo - - data FooData rngs - - class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs - - type family Head (xs :: [k]) where Head (x ': xs) = x - -GHC correctly infers that the extra-constraints wildcard on `bar` -should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this -constraint as a Given on the implication constraint for `bar`. (This -implication is emitted by emitResidualConstraints.) The Hole for the _ -is stored within the implication's WantedConstraints. When -simplifyHoles is called, that constraint is already assumed as a -Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r, -r'), Foo rngs), which is disastrous. - -Furthermore, there is no need to simplify here: extra-constraints wildcards -are filled in with the output of the solver, in chooseInferredQuantifiers -(choose_psig_context), so they are already simplified. (Contrast to normal -type holes, which are just bound to a meta-variable.) Avoiding the poor output -is simple: just don't simplify extra-constraints wildcards. - -This is the only reason we need to track ConstraintHole separately -from TypeHole in HoleSort. - -See also Note [Extra-constraint holes in partial type signatures] -in GHC.Tc.Gen.HsType. - -Note [Tracking redundant constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Opt_WarnRedundantConstraints, GHC can report which -constraints of a type signature (or instance declaration) are -redundant, and can be omitted. Here is an overview of how it -works. - -This is all tested in typecheck/should_compile/T20602 (among -others). - ------ What is a redundant constraint? - -* The things that can be redundant are precisely the Given - constraints of an implication. - -* A constraint can be redundant in two different ways: - a) It is not needed by the Wanted constraints covered by the - implication E.g. - f :: Eq a => a -> Bool - f x = True -- Equality not used - b) It is implied by other givens. E.g. - f :: (Eq a, Ord a) => blah -- Eq a unnecessary - g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary - -* To find (a) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - -* To find (b), we use mkMinimalBySCs on the Givens to see if any - are unnecessary. - ------ How tracking works - -(RC1) When two Givens are the same, we drop the evidence for the one - that requires more superclass selectors. This is done - according to 2(c) of Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. - -(RC2) The ic_need fields of an Implic records in-scope (given) evidence - variables bound by the context, that were needed to solve this - implication (so far). See the declaration of Implication. - -(RC3) setImplicationStatus: - When the constraint solver finishes solving all the wanteds in - an implication, it sets its status to IC_Solved - - - The ics_dead field, of IC_Solved, records the subset of this - implication's ic_given that are redundant (not needed). - - - We compute which evidence variables are needed by an implication - in setImplicationStatus. A variable is needed if - a) it is free in the RHS of a Wanted EvBind, - b) it is free in the RHS of an EvBind whose LHS is needed, or - c) it is in the ics_need of a nested implication. - - - After computing which variables are needed, we then look at the - remaining variables for internal redundancies. This is case (b) - from above. This is also done in setImplicationStatus. - Note that we only look for case (b) if case (a) shows up empty, - as exemplified below. - - - We need to be careful not to discard an implication - prematurely, even one that is fully solved, because we might - thereby forget which variables it needs, and hence wrongly - report a constraint as redundant. But we can discard it once - its free vars have been incorporated into its parent; or if it - simply has no free vars. This careful discarding is also - handled in setImplicationStatus. - -(RC4) We do not want to report redundant constraints for implications - that come from quantified constraints. Example #23323: - data T a - instance Show (T a) where ... -- No context! - foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int - bar = foo @T @Eq - - The call to `foo` gives us - [W] d : (forall a. Eq a => Show (T a)) - To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: - forall a. Eq a => [W] ds : Show (T a) - and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` - constraint. But we don't want to report it as redundant! - -* Examples: - - f, g, h :: (Eq a, Ord a) => a -> Bool - f x = x == x - g x = x > x - h x = x == x && x > x - - All three will discover that they have two [G] Eq a constraints: - one as given and one extracted from the Ord a constraint. They will - both discard the latter, as noted above and in - Note [Replacement vs keeping] in GHC.Tc.Solver.Interact. - - The body of f uses the [G] Eq a, but not the [G] Ord a. It will - report a redundant Ord a using the logic for case (a). - - The body of g uses the [G] Ord a, but not the [G] Eq a. It will - report a redundant Eq a using the logic for case (a). - - The body of h uses both [G] Ord a and [G] Eq a. Case (a) will - thus come up with nothing redundant. But then, the case (b) - check will discover that Eq a is redundant and report this. - - If we did case (b) even when case (a) reports something, then - we would report both constraints as redundant for f, which is - terrible. - ------ Reporting redundant constraints - -* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints. - -* We don't report redundant givens for *every* implication; only - for those which reply True to GHC.Tc.Solver.warnRedundantGivens: - - - For example, in a class declaration, the default method *can* - use the class constraint, but it certainly doesn't *have* to, - and we don't want to report an error there. - - - More subtly, in a function definition - f :: (Ord a, Ord a, Ix a) => a -> a - f x = rhs - we do an ambiguity check on the type (which would find that one - of the Ord a constraints was redundant), and then we check that - the definition has that type (which might find that both are - redundant). We don't want to report the same error twice, so we - disable it for the ambiguity check. Hence using two different - FunSigCtxts, one with the warn-redundant field set True, and the - other set False in - - GHC.Tc.Gen.Bind.tcSpecPrag - - GHC.Tc.Gen.Bind.tcTySig - - This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. - ------ Shortcomings - -Consider - - j :: (Eq a, a ~ b) => a -> Bool - j x = x == x - - k :: (Eq a, b ~ a) => a -> Bool - k x = x == x - -Currently (Nov 2021), j issues no warning, while k says that b ~ a -is redundant. This is because j uses the a ~ b constraint to rewrite -everything to be in terms of b, while k does none of that. This is -ridiculous, but I (Richard E) don't see a good fix. - --} - --- | Like 'defaultTyVar', but in the TcS monad. -defaultTyVarTcS :: TcTyVar -> TcS Bool -defaultTyVarTcS the_tv - | isTyVarTyVar the_tv - -- TyVarTvs should only be unified with a tyvar - -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar - -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - = return False - | isRuntimeRepVar the_tv - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy - ; return True } - | isLevityVar the_tv - = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv) - ; unifyTyVar the_tv liftedDataConTy - ; return True } - | isMultiplicityVar the_tv - = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) - ; unifyTyVar the_tv ManyTy - ; return True } - | otherwise - = return False -- the common case - -approximateWC :: Bool -> WantedConstraints -> Cts --- Second return value is the depleted wc --- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated --- Postcondition: Wanted Cts --- See Note [ApproximateWC] --- See Note [floatKindEqualities vs approximateWC] -approximateWC float_past_equalities wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts - float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) - = filterBag (is_floatable trapping_tvs) simples `unionBags` - concatMapBag (float_implic trapping_tvs) implics - float_implic :: TcTyCoVarSet -> Implication -> Cts - float_implic trapping_tvs imp - | float_past_equalities || ic_given_eqs imp /= MaybeGivenEqs - = float_wc new_trapping_tvs (ic_wanted imp) - | otherwise -- Take care with equalities - = emptyCts -- See (1) under Note [ApproximateWC] - where - new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - - is_floatable skol_tvs ct - | isGivenCt ct = False - | insolubleEqCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - -{- Note [ApproximateWC] -~~~~~~~~~~~~~~~~~~~~~~~ -approximateWC takes a constraint, typically arising from the RHS of a -let-binding whose type we are *inferring*, and extracts from it some -*simple* constraints that we might plausibly abstract over. Of course -the top-level simple constraints are plausible, but we also float constraints -out from inside, if they are not captured by skolems. - -The same function is used when doing type-class defaulting (see the call -to applyDefaultingRules) to extract constraints that might be defaulted. - -There is one caveat: - -1. When inferring most-general types (in simplifyInfer), we do *not* - float anything out if the implication binds equality constraints, - because that defeats the OutsideIn story. Consider - data T a where - TInt :: T Int - MkT :: T a - - f TInt = 3::Int - - We get the implication (a ~ Int => res ~ Int), where so far we've decided - f :: T a -> res - We don't want to float (res~Int) out because then we'll infer - f :: T a -> Int - which is only on of the possible types. (GHC 7.6 accidentally *did* - float out of such implications, which meant it would happily infer - non-principal types.) - - HOWEVER (#12797) in findDefaultableGroups we are not worried about - the most-general type; and we /do/ want to float out of equalities. - Hence the boolean flag to approximateWC. - ------- Historical note ----------- -There used to be a second caveat, driven by #8155 - - 2. We do not float out an inner constraint that shares a type variable - (transitively) with one that is trapped by a skolem. Eg - forall a. F a ~ beta, Integral beta - We don't want to float out (Integral beta). Doing so would be bad - when defaulting, because then we'll default beta:=Integer, and that - makes the error message much worse; we'd get - Can't solve F a ~ Integer - rather than - Can't solve Integral (F a) - - Moreover, floating out these "contaminated" constraints doesn't help - when generalising either. If we generalise over (Integral b), we still - can't solve the retained implication (forall a. F a ~ b). Indeed, - arguably that too would be a harder error to understand. - -But this transitive closure stuff gives rise to a complex rule for -when defaulting actually happens, and one that was never documented. -Moreover (#12923), the more complex rule is sometimes NOT what -you want. So I simply removed the extra code to implement the -contamination stuff. There was zero effect on the testsuite (not even #8155). ------- End of historical note ----------- - -Note [DefaultTyVar] -~~~~~~~~~~~~~~~~~~~ -defaultTyVar is used on any un-instantiated meta type variables to -default any RuntimeRep variables to LiftedRep. This is important -to ensure that instance declarations match. For example consider - - instance Show (a->b) - foo x = show (\_ -> True) - -Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), -and that won't match the typeKind (*) in the instance decl. See tests -tc217 and tc175. - -We look only at touchable type variables. No further constraints -are going to affect these type variables, so it's time to do it by -hand. However we aren't ready to default them fully to () or -whatever, because the type-class defaulting rules have yet to run. - -An alternate implementation would be to emit a Wanted constraint setting -the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. - -Note [Promote _and_ default when inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are inferring a type, we simplify the constraint, and then use -approximateWC to produce a list of candidate constraints. Then we MUST - - a) Promote any meta-tyvars that have been floated out by - approximateWC, to restore invariant (WantedInv) described in - Note [TcLevel invariants] in GHC.Tc.Utils.TcType. - - b) Default the kind of any meta-tyvars that are not mentioned in - in the environment. - -To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we -have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it -should! If we don't solve the constraint, we'll stupidly quantify over -(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over -(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. -#7641 is a simpler example. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(WantedInv) from Note [TcLevel invariants] in GHC.Tc.Types.TcType. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx - - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) - - -********************************************************************************* -* * -* Defaulting and disambiguation * -* * -********************************************************************************* - -Note [Defaulting plugins] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Defaulting plugins enable extending or overriding the defaulting -behaviour. In `applyDefaulting`, before the built-in defaulting -mechanism runs, the loaded defaulting plugins are passed the -`WantedConstraints` and get a chance to propose defaulting assignments -based on them. - -Proposals are represented as `[DefaultingProposal]` with each proposal -consisting of a type variable to fill-in, the list of defaulting types to -try in order, and a set of constraints to check at each try. This is -the same representation (albeit in a nicely packaged-up data type) as -the candidates generated by the built-in defaulting mechanism, so the -actual trying of proposals is done by the same `disambigGroup` function. - -Wrinkle (DP1): The role of `WantedConstraints` - - Plugins are passed `WantedConstraints` that can perhaps be - progressed on by defaulting. But a defaulting plugin is not a solver - plugin, its job is to provide defaulting proposals, i.e. mappings of - type variable to types. How do plugins know which type variables - they are supposed to default? - - The `WantedConstraints` passed to the defaulting plugin are zonked - beforehand to ensure all remaining metavariables are unfilled. Thus, - the `WantedConstraints` serve a dual purpose: they are both the - constraints of the given context that can act as hints to the - defaulting, as well as the containers of the type variables under - consideration for defaulting. - -Wrinkle (DP2): Interactions between defaulting mechanisms - - In the general case, we have multiple defaulting plugins loaded and - there is also the built-in defaulting mechanism. In this case, we - have to be careful to keep the `WantedConstraints` passed to the - plugins up-to-date by zonking between successful defaulting - rounds. Otherwise, two plugins might come up with a defaulting - proposal for the same metavariable; if the first one is accepted by - `disambigGroup` (thus the meta gets filled), the second proposal - becomes invalid (see #23821 for an example). - --} - -applyDefaultingRules :: WantedConstraints -> TcS Bool --- True <=> I did some defaulting, by unifying a meta-tyvar --- Input WantedConstraints are not necessarily zonked - -applyDefaultingRules wanteds - | isEmptyWC wanteds - = return False - | otherwise - = do { info@(default_tys, _) <- getDefaultInfo - ; wanteds <- TcS.zonkWC wanteds - - ; tcg_env <- TcS.getGblEnv - ; let plugins = tcg_defaulting_plugins tcg_env - - -- Run any defaulting plugins - -- See Note [Defaulting plugins] for an overview - ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else - do { - ; traceTcS "defaultingPlugins {" (ppr wanteds) - ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins - ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) - ; return (wanteds, defaultedGroups) - } - - ; let groups = findDefaultableGroups info wanteds - - ; traceTcS "applyDefaultingRules {" $ - vcat [ text "wanteds =" <+> ppr wanteds - , text "groups =" <+> ppr groups - , text "info =" <+> ppr info ] - - ; something_happeneds <- mapM (disambigGroup default_tys) groups - - ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - - ; return $ or something_happeneds || or plugin_defaulted } - where run_defaulting_plugin wanteds p = - do { groups <- runTcPluginTcS (p wanteds) - ; defaultedGroups <- - filterM (\g -> disambigGroup - (deProposalCandidates g) - (deProposalTyVar g, deProposalCts g)) - groups - ; traceTcS "defaultingPlugin " $ ppr defaultedGroups - ; case defaultedGroups of - [] -> return (wanteds, False) - _ -> do - -- If a defaulting plugin solves any tyvars, some of the wanteds - -- will have filled-in metavars by now (see wrinkle DP2 of - -- Note [Defaulting plugins]). So we re-zonk to make sure later - -- defaulting doesn't try to solve the same metavars. - wanteds' <- TcS.zonkWC wanteds - return (wanteds', True) - } - - -findDefaultableGroups - :: ( [Type] - , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved - -> [(TyVar, [Ct])] -findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds - | null default_tys - = [] - | otherwise - = [ (tv, map fstOf3 group) - | group'@((_,_,tv) :| _) <- unary_groups - , let group = toList group' - , defaultable_tyvar tv - , defaultable_classes (map sndOf3 group) ] - where - simples = approximateWC True wanteds - (unaries, non_unaries) = partitionWith find_unary (bagToList simples) - unary_groups = equivClasses cmp_tv unaries - - unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints - unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints - non_unaries :: [Ct] -- and *other* constraints - - -- Finds unary type-class constraints - -- But take account of polykinded classes like Typeable, - -- which may look like (Typeable * (a:*)) (#8931) - find_unary :: Ct -> Either (Ct, Class, TyVar) Ct - find_unary cc - | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys - -- Ignore invisible arguments for this purpose - , Just tv <- getTyVar_maybe ty - , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and - -- we definitely don't want to try to assign to those! - = Left (cc, cls, tv) - find_unary cc = Right cc -- Non unary or non dictionary - - bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries - - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_tyvar :: TcTyVar -> Bool - defaultable_tyvar tv - = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] - b2 = not (tv `elemVarSet` bad_tvs) - in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] - - defaultable_classes :: [Class] -> Bool - defaultable_classes clss - | extended_defaults = any (isInteractiveClass ovl_strings) clss - | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) - - -- is_std_class adds IsString to the standard numeric classes, - -- when -XOverloadedStrings is enabled - is_std_class cls = isStandardClass cls || - (ovl_strings && (cls `hasKey` isStringClassKey)) - ------------------------------- -disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All constraints sharing same type variable - -> TcS Bool -- True <=> something happened, reflected in ty_binds - -disambigGroup [] _ - = return False -disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) - = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) - ; fake_ev_binds_var <- TcS.newTcEvBinds - ; tclvl <- TcS.getTcLevel - ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group - - ; if success then - -- Success: record the type variable binding, and return - do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty - ; traceTcS "disambigGroup succeeded }" (ppr default_ty) - ; return True } - else - -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types }" - (ppr default_ty) - ; disambigGroup default_tys group } } - where - try_group - | Just subst <- mb_subst - = do { lcl_env <- TcS.getLclEnv - ; tc_lvl <- TcS.getTcLevel - ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env +{-# LANGUAGE MultiWayIf, RecursiveDo, TupleSections #-} + +module GHC.Tc.Solver( + InferMode(..), simplifyInfer, findInferredDiff, + growThetaTyVars, + simplifyAmbiguityCheck, + simplifyDefault, + simplifyTop, simplifyTopImplic, + simplifyInteractive, + solveEqualities, + pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX, + reportUnsolvedEqualities, + simplifyWantedsTcM, + tcCheckGivens, + tcCheckWanteds, + tcNormalise, + + captureTopConstraints, + + simplifyTopWanteds, + + promoteTyVarSet, simplifyAndEmitFlatConstraints, + + -- For Rules we need these + solveWanteds, + approximateWC + + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.Class +import GHC.Core +import GHC.Core.DataCon +import GHC.Core.Make +import GHC.Driver.DynFlags +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Types.Name +import GHC.Types.Id +import GHC.Utils.Outputable +import GHC.Builtin.Utils +import GHC.Builtin.Names +import GHC.Tc.Errors +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Solve ( solveSimpleGivens, solveSimpleWanteds ) +import GHC.Tc.Solver.Dict ( makeSuperClasses, solveCallStack ) +import GHC.Tc.Solver.Rewrite ( rewriteType ) +import GHC.Tc.Utils.Unify ( buildTvImplication ) +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Zonk.TcType as TcM +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Tc.Instance.FunDeps +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.Ppr +import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) +import GHC.Builtin.Types +import GHC.Core.Unify ( tcMatchTyKi ) +import GHC.Unit.Module ( getModule ) +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Error +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Control.Monad.Trans.Class ( lift ) +import Control.Monad.Trans.State.Strict ( StateT(runStateT), put ) +import Data.Foldable ( toList ) +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import GHC.Data.Maybe ( mapMaybe ) + +{- +********************************************************************************* +* * +* External interface * +* * +********************************************************************************* +-} + +captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureTopConstraints m) runs m, and returns the type constraints it +-- generates plus the constraints produced by static forms inside. +-- If it fails with an exception, it reports any insolubles +-- (out of scope variables) before doing so +-- +-- captureTopConstraints is used exclusively by GHC.Tc.Module at the top +-- level of a module. +-- +-- Importantly, if captureTopConstraints propagates an exception, it +-- reports any insoluble constraints first, lest they be lost +-- altogether. This is important, because solveEqualities (maybe +-- other things too) throws an exception without adding any error +-- messages; it just puts the unsolved constraints back into the +-- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors] +-- #16376 is an example of what goes wrong if you don't do this. +-- +-- NB: the caller should bring any environments into scope before +-- calling this, so that the reportUnsolved has access to the most +-- complete GlobalRdrEnv +captureTopConstraints thing_inside + = do { static_wc_var <- TcM.newTcRef emptyWC ; + ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ + TcM.tryCaptureConstraints thing_inside + ; stWC <- TcM.readTcRef static_wc_var + + -- See GHC.Tc.Utils.Monad Note [Constraints and errors] + -- If the thing_inside threw an exception, but generated some insoluble + -- constraints, report the latter before propagating the exception + -- Otherwise they will be lost altogether + ; case mb_res of + Just res -> return (res, lie `andWC` stWC) + Nothing -> do { _ <- simplifyTop lie; failM } } + -- This call to simplifyTop is the reason + -- this function is here instead of GHC.Tc.Utils.Monad + -- We call simplifyTop so that it does defaulting + -- (esp of runtime-reps) before reporting errors + +simplifyTopImplic :: Bag Implication -> TcM () +simplifyTopImplic implics + = do { empty_binds <- simplifyTop (mkImplicWC implics) + + -- Since all the inputs are implications the returned bindings will be empty + ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) + + ; return () } + +simplifyTop :: WantedConstraints -> TcM (Bag EvBind) +-- Simplify top-level constraints +-- Usually these will be implications, +-- but when there is nothing to quantify we don't wrap +-- in a degenerate implication, so we do that here instead +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ((final_wc, unsafe_ol), binds1) <- runTcS $ + do { final_wc <- simplifyTopWanteds wanteds + ; unsafe_ol <- getSafeOverlapFailures + ; return (final_wc, unsafe_ol) } + ; traceTc "End simplifyTop }" empty + + ; binds2 <- reportUnsolved final_wc + + ; traceTc "reportUnsolved (unsafe overlapping) {" empty + ; unless (isEmptyBag unsafe_ol) $ do { + -- grab current error messages and clear, warnAllUnsolved will + -- update error messages which we'll grab and then restore saved + -- messages. + ; errs_var <- getErrsVar + ; saved_msg <- TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var emptyMessages + + ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol } + + ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var saved_msg + ; recordUnsafeInfer (mkMessages whyUnsafe) + } + ; traceTc "reportUnsolved (unsafe overlapping) }" empty + + ; return (evBindMapBinds binds1 `unionBags` binds2) } + +pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a +-- Push level, and solve all resulting equalities +-- If there are any unsolved equalities, report them +-- and fail (in the monad) +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside + = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX + "pushLevelAndSolveEqualities" thing_inside + ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted + ; return res } + +pushLevelAndSolveEqualitiesX :: String -> TcM a + -> TcM (TcLevel, WantedConstraints, a) +-- Push the level, gather equality constraints, and then solve them. +-- Returns any remaining unsolved equalities. +-- Does not report errors. +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +pushLevelAndSolveEqualitiesX callsite thing_inside + = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite) + ; (tclvl, (wanted, res)) + <- pushTcLevelM $ + do { (res, wanted) <- captureConstraints thing_inside + ; wanted <- runTcSEqualities (simplifyTopWanteds wanted) + ; return (wanted,res) } + ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted + , text "Level:" <+> ppr tclvl ]) + ; return (tclvl, wanted, res) } + +-- | Type-check a thing that emits only equality constraints, solving any +-- constraints we can and re-emitting constraints that we can't. +-- Use this variant only when we'll get another crack at it later +-- See Note [Failure in local type signatures] +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +solveEqualities :: String -> TcM a -> TcM a +solveEqualities callsite thing_inside + = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite) + ; (res, wanted) <- captureConstraints thing_inside + ; simplifyAndEmitFlatConstraints wanted + -- simplifyAndEmitFlatConstraints fails outright unless + -- the only unsolved constraints are soluble-looking + -- equalities that can float out + ; traceTc "solveEqualities }" empty + ; return res } + +simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () +-- See Note [Failure in local type signatures] +simplifyAndEmitFlatConstraints wanted + = do { -- Solve and zonk to establish the + -- preconditions for floatKindEqualities + wanted <- runTcSEqualities (solveWanteds wanted) + ; wanted <- TcM.liftZonkM $ TcM.zonkWC wanted + + ; traceTc "emitFlatConstraints {" (ppr wanted) + ; case floatKindEqualities wanted of + Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted) + -- Emit the bad constraints, wrapped in an implication + -- See Note [Wrapping failing kind equalities] + ; tclvl <- TcM.getTcLevel + ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted + -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ + -- it's OK to use unkSkol | we must increase the TcLevel, + -- because we don't bind | as explained in + -- any skolem variables here | Note [Wrapping failing kind equalities] + ; emitImplication implic + ; failM } + Just (simples, errs) + -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) + ; traceTc "emitFlatConstraints }" $ + vcat [ text "simples:" <+> ppr simples + , text "errs: " <+> ppr errs ] + -- Holes and other delayed errors don't need promotion + ; emitDelayedErrors errs + ; emitSimples simples } } + +floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) +-- Float out all the constraints from the WantedConstraints, +-- Return Nothing if any constraints can't be floated (captured +-- by skolems), or if there is an insoluble constraint, or +-- IC_Telescope telescope error +-- Precondition 1: we have tried to solve the 'wanteds', both so that +-- the ic_status field is set, and because solving can make constraints +-- more floatable. +-- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities +-- is not monadic +-- See Note [floatKindEqualities vs approximateWC] +floatKindEqualities wc = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) + float_wc trapping_tvs (WC { wc_simple = simples + , wc_impl = implics + , wc_errors = errs }) + | all is_floatable simples + = do { (inner_simples, inner_errs) + <- flatMapBagPairM (float_implic trapping_tvs) implics + ; return ( simples `unionBags` inner_simples + , errs `unionBags` inner_errs) } + | otherwise + = Nothing + where + is_floatable ct + | insolubleCt ct = False + | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs + + float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError) + float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs + , ic_skols = skols, ic_status = status }) + | isInsolubleStatus status + = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope + | otherwise + = do { (simples, holes) <- float_wc new_trapping_tvs wanted + ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $ + Nothing + -- If there are some constraints to float out, but we can't + -- because we don't float out past local equalities + -- (c.f GHC.Tc.Solver.approximateWC), then fail + ; return (simples, holes) } + where + new_trapping_tvs = trapping_tvs `extendVarSetList` skols + + +{- Note [Failure in local type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind checking a type signature, we like to fail fast if we can't +solve all the kind equality constraints, for two reasons: + + * A kind-bogus type signature may cause a cascade of knock-on + errors if we let it pass + + * More seriously, we don't have a convenient term-level place to add + deferred bindings for unsolved kind-equality constraints. In + earlier GHCs this led to un-filled-in coercion holes, which caused + GHC to crash with "fvProv falls into a hole" See #11563, #11520, + #11516, #11399 + +But what about /local/ type signatures, mentioning in-scope type +variables for which there might be 'given' equalities? For these we +might not be able to solve all the equalities locally. Here's an +example (T15076b): + + class (a ~ b) => C a b + data SameKind :: k -> k -> Type where { SK :: SameKind a b } + + bar :: forall (a :: Type) (b :: Type). + C a b => Proxy a -> Proxy b -> () + bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) + +Consider the type signature on 'undefined'. It's ill-kinded unless +a~b. But the superclass of (C a b) means that indeed (a~b). So all +should be well. BUT it's hard to see that when kind-checking the signature +for undefined. We want to emit a residual (a~b) constraint, to solve +later. + +Another possibility is that we might have something like + F alpha ~ [Int] +where alpha is bound further out, which might become soluble +"later" when we learn more about alpha. So we want to emit +those residual constraints. + +BUT it's no good simply wrapping all unsolved constraints from +a type signature in an implication constraint to solve later. The +problem is that we are going to /use/ that signature, including +instantiate it. Say we have + f :: forall a. (forall b. blah) -> blah2 + f x = +To typecheck the definition of f, we have to instantiate those +foralls. Moreover, any unsolved kind equalities will be coercion +holes in the type. If we naively wrap them in an implication like + forall a. (co1:k1~k2, forall b. co2:k3~k4) +hoping to solve it later, we might end up filling in the holes +co1 and co2 with coercions involving 'a' and 'b' -- but by now +we've instantiated the type. Chaos! + +Moreover, the unsolved constraints might be skolem-escape things, and +if we proceed with f bound to a nonsensical type, we get a cascade of +follow-up errors. For example polykinds/T12593, T15577, and many others. + +So here's the plan (see tcHsSigType): + +* pushLevelAndSolveEqualitiesX: try to solve the constraints + +* kindGeneraliseSome: do kind generalisation + +* buildTvImplication: build an implication for the residual, unsolved + constraint + +* simplifyAndEmitFlatConstraints: try to float out every unsolved equality + inside that implication, in the hope that it constrains only global + type variables, not the locally-quantified ones. + + * If we fail, or find an insoluble constraint, emit the implication, + so that the errors will be reported, and fail. + + * If we succeed in floating all the equalities, promote them and + re-emit them as flat constraint, not wrapped at all (since they + don't mention any of the quantified variables. + +* Note that this float-and-promote step means that anonymous + wildcards get floated to top level, as we want; see + Note [Checking partial type signatures] in GHC.Tc.Gen.HsType. + +All this is done: + +* In GHC.Tc.Gen.HsType.tcHsSigType, as above + +* solveEqualities. Use this when there no kind-generalisation + step to complicate matters; then we don't need to push levels, + and can solve the equalities immediately without needing to + wrap it in an implication constraint. (You'll generally see + a kindGeneraliseNone nearby.) + +* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to + pushLevelAndSolveEqualitiesX, followed by quantification, and + then reportUnsolvedEqualities. + + NB: we call reportUnsolvedEqualities before zonkTcTypeToType + because the latter does not expect to see any un-filled-in + coercions, which will happen if we have unsolved equalities. + By calling reportUnsolvedEqualities first, which fails after + reporting errors, we avoid that happening. + +See also #18062, #11506 + +Note [Wrapping failing kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In simplifyAndEmitFlatConstraints, if we fail to get down to simple +flat constraints we will +* re-emit the constraints so that they are reported +* fail in the monad +But there is a Terrible Danger that, if -fdefer-type-errors is on, and +we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll +report only a warning and proceed with compilation. But if we ever fail +in the monad it should be fatal; we should report an error and stop after +the type checker. If not, chaos results: #19142. + +Our solution is this: +* Even with -fdefer-type-errors, inside an implication with no place for + value bindings (ic_binds = CoEvBindsVar), report failing equalities as + errors. We have to do this anyway; see GHC.Tc.Errors + Note [Failing equalities with no evidence bindings]. + +* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication + to wrap the failing constraint in a degenerate implication (no + skolems, no theta), with ic_binds = CoEvBindsVar. This setting of + `ic_binds` means that any failing equalities will lead to an + error not a warning, irrespective of -fdefer-type-errors: see + Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors, + and `maybeSwitchOffDefer` in that module. + + We still take care to bump the TcLevel of the implication. Partly, + that ensures that nested implications have increasing level numbers + which seems nice. But more specifically, suppose the outer level + has a Given `(C ty)`, which has pending (not-yet-expanded) + superclasses. Consider what happens when we process this implication + constraint (which we have re-emitted) in that context: + - in the inner implication we'll call `getPendingGivenScs`, + - we /do not/ want to get the `(C ty)` from the outer level, + lest we try to add an evidence term for the superclass, + which we can't do because we have specifically set + `ic_binds` = `CoEvBindsVar`. + - as `getPendingGivenSCcs is careful to only get Givens from + the /current/ level, and we bumped the `TcLevel` of the implication, + we're OK. + + TL;DR: bump the `TcLevel` when creating the nested implication. + If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043). + + +We re-emit the implication rather than reporting the errors right now, +so that the error messages are improved by other solving and defaulting. +e.g. we prefer + Cannot match 'Type->Type' with 'Type' +to Cannot match 'Type->Type' with 'TYPE r0' + + +Note [floatKindEqualities vs approximateWC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +floatKindEqualities and approximateWC are strikingly similar to each +other, but + +* floatKindEqualites tries to float /all/ equalities, and fails if + it can't, or if any implication is insoluble. +* approximateWC just floats out any constraints + (not just equalities) that can float; it never fails. +-} + + +reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +-- Reports all unsolved wanteds provided; fails in the monad if there are any. +-- +-- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to +-- provide skolem info for any errors. +reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted + +report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted + | isEmptyWC wanted + = return () + + | otherwise -- NB: we build an implication /even if skol_tvs is empty/, + -- just to ensure that our level invariants hold, specifically + -- (WantedInv). See Note [TcLevel invariants]. + = checkNoErrs $ -- Fail + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted + ; reportAllUnsolved (mkImplicWC (unitBag implic)) } + + +-- | Simplify top-level constraints, but without reporting any unsolved +-- constraints nor unsafe overlapping. +simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints + -- See Note [Top-level Defaulting Plan] +simplifyTopWanteds wanteds + = do { wc_first_go <- nestTcS (solveWanteds wanteds) + -- This is where the main work happens + ; dflags <- getDynFlags + ; wc_defaulted <- try_tyvar_defaulting dflags wc_first_go + + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (C). + ; useUnsatisfiableGivens wc_defaulted } + where + try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints + try_tyvar_defaulting dflags wc + | isEmptyWC wc + = return wc + | insolubleWC wc + , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] + = try_class_defaulting wc + | otherwise + = do { -- Need to zonk first, as the WantedConstraints are not yet zonked. + ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) + ; let defaultable_tvs = filter can_default free_tvs + can_default tv + = isTyVar tv + -- Weed out coercion variables. + + && isMetaTyVar tv + -- Weed out runtime-skolems in GHCi, which we definitely + -- shouldn't try to default. + + && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc) + -- Weed out variables for which defaulting would be unhelpful, + -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk]. + + ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects + ; if or defaulted + then do { wc_residual <- nestTcS (solveWanteds wc) + -- See Note [Must simplify after defaulting] + ; try_class_defaulting wc_residual } + else try_class_defaulting wc } -- No defaulting took place + + try_class_defaulting :: WantedConstraints -> TcS WantedConstraints + try_class_defaulting wc + | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] + = try_callstack_defaulting wc + | otherwise -- See Note [When to do type-class defaulting] + = do { something_happened <- applyDefaultingRules wc + -- See Note [Top-level Defaulting Plan] + ; if something_happened + then do { wc_residual <- nestTcS (solveWanteds wc) + ; try_class_defaulting wc_residual } + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + else try_callstack_defaulting wc } + + try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints + try_callstack_defaulting wc + | isEmptyWC wc + = return wc + | otherwise + = defaultCallStacks wc + +-- | If an implication contains a Given of the form @Unsatisfiable msg@, use +-- it to solve all Wanteds within the implication. +-- +-- This does a complete walk over the implication tree. +-- +-- See point (C) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. +useUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints +useUnsatisfiableGivens wc = + do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc + ; if did_work + then nestTcS (solveWanteds final_wc) + else return final_wc } + where + go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs }) + = do impls' <- mapMaybeBagM go_impl impls + return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs } + go_impl impl + | isSolvedStatus (ic_status impl) + = return $ Just impl + -- Is there a Given with type "Unsatisfiable msg"? + -- If so, use it to solve all other Wanteds. + | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl) + = do { put True + ; lift $ solveImplicationUsingUnsatGiven unsat_given impl } + -- Otherwise, recurse. + | otherwise + = do { wcs' <- go_wc (ic_wanted impl) + ; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } } + +-- | Is this evidence variable the evidence for an 'Unsatisfiable' constraint? +-- +-- If so, return the variable itself together with the error message type. +unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type) +unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v) + +-- | We have an implication with an 'Unsatisfiable' Given; use that Given to +-- solve all the other Wanted constraints, including those nested within +-- deeper implications. +solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS (Maybe Implication) +solveImplicationUsingUnsatGiven + unsat_given@(given_ev,_) + impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var, ic_need_inner = inner }) + | isCoEvBindsVar ev_binds_var + -- We can't use Unsatisfiable evidence in kinds. + -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence. + = return $ Just impl + | otherwise + = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd + ; setImplicationStatus $ + impl { ic_wanted = wcs + , ic_need_inner = inner `extendVarSet` given_ev } } + where + go_wc :: WantedConstraints -> TcS WantedConstraints + go_wc wc@(WC { wc_simple = wtds, wc_impl = impls }) + = do { mapBagM_ go_simple wtds + ; impls <- mapMaybeBagM (solveImplicationUsingUnsatGiven unsat_given) impls + ; return $ wc { wc_simple = emptyBag, wc_impl = impls } } + go_simple :: Ct -> TcS () + go_simple ct = case ctEvidence ct of + CtWanted { ctev_pred = pty, ctev_dest = dst } + -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty + ; setWantedEvTerm dst True $ EvExpr ev_expr } + _ -> return () + +-- | Create an evidence expression for an arbitrary constraint using +-- evidence for an "Unsatisfiable" Given. +-- +-- See Note [Evidence terms from Unsatisfiable Givens] +unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr +unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty + = do { mod <- getModule + -- If we're typechecking GHC.TypeError, return a bogus expression; + -- it's only used for the ambiguity check, which throws the evidence away anyway. + -- This avoids problems with circularity; where we are trying to look + -- up the "unsatisfiable" Id while we are in the middle of typechecking it. + ; if mod == gHC_TYPEERROR then return (Var unsat_ev) else + do { unsatisfiable_id <- tcLookupId unsatisfiableIdName + + -- See Note [Evidence terms from Unsatisfiable Givens] + -- for a description of what evidence term we are constructing here. + + ; let -- (##) -=> wtd_ty + fun_ty = mkFunTy visArgConstraintLike ManyTy unboxedUnitTy wtd_ty + mkDictBox = case boxingDataCon fun_ty of + BI_Box { bi_data_con = mkDictBox } -> mkDictBox + _ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty) + dictBox = dataConTyCon mkDictBox + ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty + -- Dict ((##) -=> wtd_ty) + ; let scrut_ty = mkTyConApp dictBox [fun_ty] + -- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev + scrut = + mkCoreApps (Var unsatisfiable_id) + [ Type liftedRepTy + , Type given_msg + , Type scrut_ty + , Var unsat_ev ] + -- case scrut of { MkDictBox @((##) -=> wtd_ty)) ct -> ct (# #) } + ev_expr = + mkWildCase scrut (unrestricted $ scrut_ty) wtd_ty + [ Alt (DataAlt mkDictBox) [ev_bndr] $ + mkCoreApps (Var ev_bndr) [unboxedUnitExpr] + ] + ; return ev_expr } } + +{- Note [Evidence terms from Unsatisfiable Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An Unsatisfiable Given constraint, of the form [G] Unsatisfiable msg, should be +able to solve ANY Wanted constraint whatsoever. + +Recall that we have + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep) + . Unsatisfiable msg => a + +We want to use this function, together with the evidence +[G] unsat_ev :: Unsatisfiable msg, to solve any other constraint [W] wtd_ty. + +We could naively think that a valid evidence term for the Wanted might be: + + wanted_ev = unsatisfiable @{rep} @msg @wtd_ty unsat_ev + +Unfortunately, this is a kind error: "wtd_ty :: CONSTRAINT rep", but +"unsatisfiable" expects the third type argument to be of kind "TYPE rep". + +Instead, we use a boxing data constructor to box the constraint into a type. +In the end, we construct the following evidence for the implication: + + [G] unsat_ev :: Unsatisfiable msg + ==> + [W] wtd_ev :: wtd_ty + + wtd_ev = + case unsatisfiable @{LiftedRep} @msg @(Dict ((##) -=> wtd_ty)) unsat_ev of + MkDictBox ct -> ct (# #) + +Note that we play the same trick with the function arrow -=> that we did +in order to define "unsatisfiable" in terms of "unsatisfiableLifted", as described +in Note [The Unsatisfiable representation-polymorphism trick] in base:GHC.TypeError. +This allows us to indirectly box constraints with different representations +(such as primitive equality constraints). +-} + +-- | Default any remaining @CallStack@ constraints to empty @CallStack@s. +defaultCallStacks :: WantedConstraints -> TcS WantedConstraints +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +defaultCallStacks wanteds + = do simples <- handle_simples (wc_simple wanteds) + mb_implics <- mapBagM handle_implic (wc_impl wanteds) + return (wanteds { wc_simple = simples + , wc_impl = catBagMaybes mb_implics }) + + where + + handle_simples simples + = catBagMaybes <$> mapBagM defaultCallStack simples + + handle_implic :: Implication -> TcS (Maybe Implication) + -- The Maybe is because solving the CallStack constraint + -- may well allow us to discard the implication entirely + handle_implic implic + | isSolvedStatus (ic_status implic) + = return (Just implic) + | otherwise + = do { wanteds <- setEvBindsTcS (ic_binds implic) $ + -- defaultCallStack sets a binding, so + -- we must set the correct binding group + defaultCallStacks (ic_wanted implic) + ; setImplicationStatus (implic { ic_wanted = wanteds }) } + + defaultCallStack ct + | ClassPred cls tys <- classifyPredType (ctPred ct) + , Just {} <- isCallStackPred cls tys + = do { solveCallStack (ctEvidence ct) EvCsEmpty + ; return Nothing } + + defaultCallStack ct + = return (Just ct) + + +{- Note [When to do type-class defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC +was false, on the grounds that defaulting can't help solve insoluble +constraints. But if we *don't* do defaulting we may report a whole +lot of errors that would be solved by defaulting; these errors are +quite spurious because fixing the single insoluble error means that +defaulting happens again, which makes all the other errors go away. +This is jolly confusing: #9033. + +So it seems better to always do type-class defaulting. + +However, always doing defaulting does mean that we'll do it in +situations like this (#5934): + run :: (forall s. GenST s) -> Int + run = fromInteger 0 +We don't unify the return type of fromInteger with the given function +type, because the latter involves foralls. So we're left with + (Num alpha, alpha ~ (forall s. GenST s) -> Int) +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally +stupid, but perhaps a little strange. + +Another potential alternative would be to suppress *all* non-insoluble +errors if there are *any* insoluble errors, anywhere, but that seems +too drastic. + +Note [Don't default in syntactic equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there are unsolved syntactic equalities such as + + rr[sk] ~S# alpha[conc] + +we should not default alpha, lest we obtain a poor error message such as + + Couldn't match kind `rr' with `LiftedRep' + +We would rather preserve the original syntactic equality to be +reported to the user, especially as the concrete metavariable alpha +might store an informative origin for the user. + +Note [Must simplify after defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a deeply buried constraint + (t:*) ~ (a:Open) +which we couldn't solve because of the kind incompatibility, and 'a' is free. +Then when we default 'a' we can solve the constraint. And we want to do +that before starting in on type classes. We MUST do it before reporting +errors, because it isn't an error! #7967 was due to this. + +Note [Top-level Defaulting Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have considered two design choices for where/when to apply defaulting. + (i) Do it in SimplCheck mode only /whenever/ you try to solve some + simple constraints, maybe deep inside the context of implications. + This used to be the case in GHC 7.4.1. + (ii) Do it in a tight loop at simplifyTop, once all other constraints have + finished. This is the current story. + +Option (i) had many disadvantages: + a) Firstly, it was deep inside the actual solver. + b) Secondly, it was dependent on the context (Infer a type signature, + or Check a type signature, or Interactive) since we did not want + to always start defaulting when inferring (though there is an exception to + this, see Note [Default while Inferring]). + c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: + f :: Int -> Bool + f x = const True (\y -> let w :: a -> a + w a = const a (y+1) + in w y) + We will get an implication constraint (for beta the type of y): + [untch=beta] forall a. 0 => Num beta + which we really cannot default /while solving/ the implication, since beta is + untouchable. + +Instead our new defaulting story is to pull defaulting out of the solver loop and +go with option (ii), implemented at SimplifyTop. Namely: + - First, have a go at solving the residual constraint of the whole + program + - Try to approximate it with a simple constraint + - Figure out derived defaulting equations for that simple constraint + - Go round the loop again if you did manage to get some equations + +Now, that has to do with class defaulting. However there exists type variable /kind/ +defaulting. Again this is done at the top-level and the plan is: + - At the top-level, once you had a go at solving the constraint, do + figure out /all/ the touchable unification variables of the wanted constraints. + - Apply defaulting to their kinds + +More details in Note [DefaultTyVar]. + +Note [Safe Haskell Overlapping Instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Safe Haskell, we apply an extra restriction to overlapping instances. The +motive is to prevent untrusted code provided by a third-party, changing the +behavior of trusted code through type-classes. This is due to the global and +implicit nature of type-classes that can hide the source of the dictionary. + +Another way to state this is: if a module M compiles without importing another +module N, changing M to import N shouldn't change the behavior of M. + +Overlapping instances with type-classes can violate this principle. However, +overlapping instances aren't always unsafe. They are just unsafe when the most +selected dictionary comes from untrusted code (code compiled with -XSafe) and +overlaps instances provided by other modules. + +In particular, in Safe Haskell at a call site with overlapping instances, we +apply the following rule to determine if it is a 'unsafe' overlap: + + 1) Most specific instance, I1, defined in an `-XSafe` compiled module. + 2) I1 is an orphan instance or a MPTC. + 3) At least one overlapped instance, Ix, is both: + A) from a different module than I1 + B) Ix is not marked `OVERLAPPABLE` + +This is a slightly involved heuristic, but captures the situation of an +imported module N changing the behavior of existing code. For example, if +condition (2) isn't violated, then the module author M must depend either on a +type-class or type defined in N. + +Secondly, when should these heuristics be enforced? We enforced them when the +type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. +This allows `-XUnsafe` modules to operate without restriction, and for Safe +Haskell inference to infer modules with unsafe overlaps as unsafe. + +One alternative design would be to also consider if an instance was imported as +a `safe` import or not and only apply the restriction to instances imported +safely. However, since instances are global and can be imported through more +than one path, this alternative doesn't work. + +Note [Safe Haskell Overlapping Instances Implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How is this implemented? It's complicated! So we'll step through it all: + + 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where + we check if a particular type-class method call is safe or unsafe. We do this + through the return type, `ClsInstLookupResult`, where the last parameter is a + list of instances that are unsafe to overlap. When the method call is safe, + the list is null. + + 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution + / dictionary generation. The return type is `ClsInstResult`, which either + says no instance matched, or one found, and if it was a safe or unsafe + overlap. + + 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and + tries to resolve it by calling (in part) `matchClassInst`. The resolving + mechanism has a work list (of constraints) that it process one at a time. If + the constraint can't be resolved, it's added to an inert set. When compiling + an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know + compilation should fail. These are handled as normal constraint resolution + failures from here-on (see step 6). + + Otherwise, we may be inferring safety (or using `-Wunsafe`), and + compilation should succeed, but print warnings and/or mark the compiled module + as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds + the unsafe (but resolved!) constraint to the `inert_safehask` field of + `InertCans`. + + 4) `GHC.Tc.Solver.simplifyTop`: + * Call simplifyTopWanteds, the top-level function for driving the simplifier for + constraint resolution. + + * Once finished, call `getSafeOverlapFailures` to retrieve the + list of overlapping instances that were successfully resolved, + but unsafe. Remember, this is only applicable for generating warnings + (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` + cause compilation failure by not resolving the unsafe constraint at all. + + * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`, + while for resolved but unsafe overlapping dictionary constraints, call + `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a + warning message for the user. + + * In the case of `warnAllUnsolved` for resolved, but unsafe + dictionary constraints, we collect the generated warning + message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to + mark the module we are compiling as unsafe, passing the + warning message along as the reason. + + 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by + actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we + know is the constraint that is unresolved or unsafe. For dictionary, all we + know is that we need a dictionary of type C, but not what instances are + available and how they overlap. So we once again call `lookupInstEnv` to + figure that out so we can generate a helpful error message. + + 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in + IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. + + 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling + `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference + failed. + +Note [No defaulting in the ambiguity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying constraints for the ambiguity check, we use +solveWanteds, not simplifyTopWanteds, so that we do no defaulting. +#11947 was an example: + f :: Num a => Int -> Int +This is ambiguous of course, but we don't want to default the +(Num alpha) constraint to (Num Int)! Doing so gives a defaulting +warning, but no error. + +Note [Defaulting insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a set of wanteds is insoluble, we have no hope of accepting the +program. Yet we do not stop constraint solving, etc., because we may +simplify the wanteds to produce better error messages. So, once +we have an insoluble constraint, everything we do is just about producing +helpful error messages. + +Should we default in this case or not? Let's look at an example (tcfail004): + + (f,g) = (1,2,3) + +With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). +Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) +find the latter more helpful. Several other test cases (e.g. tcfail005) suggest +similarly. So: we should not do class defaulting with insolubles. + +On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: + + f :: Integer i => i + f = 0 + +Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind +TYPE r0 -> Constraint and then complains that r0 is actually untouchable +(presumably, because it can't be sure if `Integer i` entails an equality). +If we default, we are told of a clash between (* -> Constraint) and Constraint. +The latter seems far better, suggesting we *should* do RuntimeRep-defaulting +even on insolubles. + +But, evidently, not always. Witness UnliftedNewtypesInfinite: + + newtype Foo = FooC (# Int#, Foo #) + +This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). +If we default RuntimeRep-vars, we get + + Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted + +which is just plain wrong. + +Another situation in which we don't want to default involves concrete metavariables. + +In equalities such as alpha[conc] ~# rr[sk] , alpha[conc] ~# RR beta[tau] +for a type family RR (all at kind RuntimeRep), we would prefer to report a +representation-polymorphism error rather than default alpha and get error: + + Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted` + +which is very confusing. For this reason, we weed out the concrete +metavariables participating in such equalities in nonDefaultableTyVarsOfWC. +Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could +become soluble after defaulting beta (see also #21430). + +Conclusion: we should do RuntimeRep-defaulting on insolubles only when the +user does not want to hear about RuntimeRep stuff -- that is, when +-fprint-explicit-runtime-reps is not set. +However, we must still take care not to default concrete type variables +participating in an equality with a non-concrete type, as seen in the +last example above. +-} + +------------------ +simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () +simplifyAmbiguityCheck ty wanteds + = do { traceTc "simplifyAmbiguityCheck {" $ + text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds + + ; (final_wc, _) <- runTcS $ useUnsatisfiableGivens =<< solveWanteds wanteds + -- NB: no defaulting! See Note [No defaulting in the ambiguity check] + -- Note: we do still use Unsatisfiable Givens to solve Wanteds, + -- see Wrinkle [Ambiguity] under point (C) of + -- Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. + + ; discardResult (reportUnsolved final_wc) + + ; traceTc "End simplifyAmbiguityCheck }" empty } + +------------------ +simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) +simplifyInteractive wanteds + = traceTc "simplifyInteractive" empty >> + simplifyTop wanteds + +------------------ +simplifyDefault :: ThetaType -- Wanted; has no type variables in it + -> TcM Bool -- Return if the constraint is soluble +simplifyDefault theta + = do { traceTc "simplifyDefault" empty + ; wanteds <- newWanteds DefaultOrigin theta + ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds)) + ; return (isEmptyWC unsolved) } + +------------------ +{- Note [Pattern match warnings with insoluble Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A pattern match on a GADT can introduce new type-level information, which needs +to be analysed in order to get the expected pattern match warnings. + +For example: + +> type IsBool :: Type -> Constraint +> type family IsBool a where +> IsBool Bool = () +> IsBool b = b ~ Bool +> +> data T a where +> MkTInt :: Int -> T Int +> MkTBool :: IsBool b => b -> T b +> +> f :: T Int -> Int +> f (MkTInt i) = i + +The pattern matching performed by `f` is complete: we can't ever call +`f (MkTBool b)`, as type-checking that application would require producing +evidence for `Int ~ Bool`, which can't be done. + +The pattern match checker uses `tcCheckGivens` to accumulate all the Given +constraints, and relies on `tcCheckGivens` to return Nothing if the +Givens become insoluble. `tcCheckGivens` in turn relies on `insolubleCt` +to identify these insoluble constraints. So the precise definition of +`insolubleCt` has a big effect on pattern match overlap warnings. + +To detect this situation, we check whether there are any insoluble Given +constraints. In the example above, the insoluble constraint was an +equality constraint, but it is also important to detect custom type errors: + +> type NotInt :: Type -> Constraint +> type family NotInt a where +> NotInt Int = TypeError (Text "That's Int, silly.") +> NotInt _ = () +> +> data R a where +> MkT1 :: a -> R a +> MkT2 :: NotInt a => R a +> +> foo :: R Int -> Int +> foo (MkT1 x) = x + +To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble +because it is a custom type error. +Failing to do so proved quite inconvenient for users, as evidence by the +tickets #11503 #14141 #16377 #20180. +Test cases: T11503, T14141. + +Examples of constraints that tcCheckGivens considers insoluble: + - Int ~ Bool, + - Coercible Float Word, + - TypeError msg. + +Non-examples: + - constraints which we know aren't satisfied, + e.g. Show (Int -> Int) when no such instance is in scope, + - Eq (TypeError msg), + - C (Int ~ Bool), with @class C (c :: Constraint)@. +-} + +tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) +-- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely +-- contradictory. +-- +-- See Note [Pattern match warnings with insoluble Givens] above. +tcCheckGivens inerts given_ids = do + (sat, new_inerts) <- runTcSInerts inerts $ do + traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) + lcl_env <- TcS.getLclEnv + let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + let given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + solveSimpleGivens given_cts + insols <- getInertInsols + insols <- try_harder insols + traceTcS "checkGivens }" (ppr insols) + return (isEmptyBag insols) + return $ if sat then Just new_inerts else Nothing + where + try_harder :: Cts -> TcS Cts + -- Maybe we have to search up the superclass chain to find + -- an unsatisfiable constraint. Example: pmcheck/T3927b. + -- At the moment we try just once + try_harder insols + | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable + = return insols -- Hurrah -- stop now. + | otherwise + = do { pending_given <- getPendingGivenScs + ; new_given <- makeSuperClasses pending_given + ; solveSimpleGivens new_given + ; getInertInsols } + +tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool +-- ^ Return True if the Wanteds are soluble, False if not +tcCheckWanteds inerts wanteds = do + cts <- newWanteds PatCheckOrigin wanteds + (sat, _new_inerts) <- runTcSInerts inerts $ do + traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) + -- See Note [Superclasses and satisfiability] + wcs <- solveWanteds (mkSimpleWC cts) + traceTcS "checkWanteds }" (ppr wcs) + return (isSolvedWC wcs) + return sat + +-- | Normalise a type as much as possible using the given constraints. +-- See @Note [tcNormalise]@. +tcNormalise :: InertSet -> Type -> TcM Type +tcNormalise inerts ty + = do { norm_loc <- getCtLocM PatCheckOrigin Nothing + ; (res, _new_inerts) <- runTcSInerts inerts $ + do { traceTcS "tcNormalise {" (ppr inerts) + ; ty' <- rewriteType norm_loc ty + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } + ; return res } + +{- Note [Superclasses and satisfiability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expand superclasses before starting, because (Int ~ Bool), has +(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) +as a superclass, and it's the latter that is insoluble. See +Note [The equality types story] in GHC.Builtin.Types.Prim. + +If we fail to prove unsatisfiability we (arbitrarily) try just once to +find superclasses, using try_harder. Reason: we might have a type +signature + f :: F op (Implements push) => .. +where F is a type function. This happened in #3972. + +We could do more than once but we'd have to have /some/ limit: in the +the recursive case, we would go on forever in the common case where +the constraints /are/ satisfiable (#10592 comment:12!). + +For straightforward situations without type functions the try_harder +step does nothing. + +Note [tcNormalise] +~~~~~~~~~~~~~~~~~~ +tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas +most invocations of the constraint solver are intended to simplify a set of +constraints or to decide if a particular set of constraints is satisfiable, +the purpose of tcNormalise is to take a type, plus some locally solved +constraints in the form of an InertSet, and normalise the type as much as +possible with respect to those constraints. + +It does *not* reduce type or data family applications or look through newtypes. + +Why is this useful? As one example, when coverage-checking an EmptyCase +expression, it's possible that the type of the scrutinee will only reduce +if some local equalities are solved for. See "Wrinkle: Local equalities" +in Note [Type normalisation] in "GHC.HsToCore.Pmc". + +To accomplish its stated goal, tcNormalise first initialises the solver monad +with the given InertCans, then uses rewriteType to simplify the desired type +with respect to the Givens in the InertCans. + +*********************************************************************************** +* * +* Inference +* * +*********************************************************************************** + +Note [Inferring the type of a let-bound variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = rhs + +To infer f's type we do the following: + * Gather the constraints for the RHS with ambient level *one more than* + the current one. This is done by the call + pushLevelAndCaptureConstraints (tcMonoBinds...) + in GHC.Tc.Gen.Bind.tcPolyInfer + + * Call simplifyInfer to simplify the constraints and decide what to + quantify over. We pass in the level used for the RHS constraints, + here called rhs_tclvl. + +This ensures that the implication constraint we generate, if any, +has a strictly-increased level compared to the ambient level outside +the let binding. + +Note [Inferring principal types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't always infer principal types. For instance, the inferred type for + +> f x = show [x] + +is + +> f :: Show a => a -> String + +This is not the most general type if we allow flexible contexts. +Indeed, if we try to write the following + +> g :: Show [a] => a -> String +> g x = f x + +we get the error: + + * Could not deduce (Show a) arising from a use of `f' + from the context: Show [a] + +Though replacing f x in the right-hand side of g with the definition +of f x works, the call to f x does not. This is the hallmark of +unprincip{led,al} types. + +Another example: + +> class C a +> class D a where +> d :: a +> instance C a => D a where +> d = undefined +> h _ = d -- argument is to avoid the monomorphism restriction + +The inferred type for h is + +> h :: C a => t -> a + +even though + +> h :: D a => t -> a + +is more general. + +The fix is easy: don't simplify constraints before inferring a type. +That is, have the inferred type quantify over all constraints that arise +in a definition's right-hand side, even if they are simplifiable. +Unfortunately, this would yield all manner of unwieldy types, +and so we won't do so. +-} + +-- | How should we choose which constraints to quantify over? +data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, + -- never quantifying over any constraints + | EagerDefaulting -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module", + -- the :type +d case; this mode refuses + -- to quantify over any defaultable constraint + | NoRestrictions -- ^ Quantify over any constraint that + -- satisfies pickQuantifiablePreds + +instance Outputable InferMode where + ppr ApplyMR = text "ApplyMR" + ppr EagerDefaulting = text "EagerDefaulting" + ppr NoRestrictions = text "NoRestrictions" + +simplifyInfer :: TcLevel -- Used when generating the constraints + -> InferMode + -> [TcIdSigInst] -- Any signatures (possibly partial) + -> [(Name, TcTauType)] -- Variables to be generalised, + -- and their tau-types + -> WantedConstraints + -> TcM ([TcTyVar], -- Quantify over these type variables + [EvVar], -- ... and these constraints (fully zonked) + TcEvBinds, -- ... binding these evidence variables + Bool) -- True <=> the residual constraints are insoluble + +simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds + | isEmptyWC wanteds + = 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 + , (_,Bndr tv _) <- sig_inst_skols sig ] + psig_theta = [ pred | sig <- partial_sigs + , pred <- sig_inst_theta sig ] + + ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) + + ; skol_info <- mkSkolemInfo (InferSkol name_taus) + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars + ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], emptyTcEvBinds, False) } + + | otherwise + = do { traceTc "simplifyInfer {" $ vcat + [ text "sigs =" <+> ppr sigs + , text "binds =" <+> ppr name_taus + , text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "infer_mode =" <+> ppr infer_mode + , text "(unzonked) wanted =" <+> ppr wanteds + ] + + ; let psig_theta = concatMap sig_inst_theta partial_sigs + + -- First do full-blown solving + -- NB: we must gather up all the bindings from doing + -- this solving; hence (runTcSWithEvBinds ev_binds_var). + -- And note that since there are nested implications, + -- calling solveWanteds will side-effect their evidence + -- bindings, so we can't just revert to the input + -- constraint. + + ; ev_binds_var <- TcM.newTcEvBinds + ; psig_evs <- newWanteds AnnOrigin psig_theta + ; wanted_transformed + <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds ev_binds_var $ + solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) + -- psig_evs : see Note [Add signature contexts as wanteds] + -- See Note [Inferring principal types] + + -- Find quant_pred_candidates, the predicates that + -- we'll consider quantifying over + -- NB1: wanted_transformed does not include anything provable from + -- the psig_theta; it's just the extra bit + -- NB2: We do not do any defaulting when inferring a type, this can lead + -- to less polymorphic types, see Note [Default while Inferring] + ; wanted_transformed <- TcM.liftZonkM $ TcM.zonkWC wanted_transformed + ; let definite_error = insolubleWC wanted_transformed + -- See Note [Quantification with errors] + quant_pred_candidates + | definite_error = [] + | otherwise = ctsPreds (approximateWC False wanted_transformed) + + -- Decide what type variables and constraints to quantify + -- NB: quant_pred_candidates is already fully zonked + -- NB: bound_theta are constraints we want to quantify over, + -- including the psig_theta, which we always quantify over + -- NB: bound_theta are fully zonked + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl + name_taus partial_sigs + quant_pred_candidates + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + + ; let full_theta = map idType bound_theta_vars + ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty) + | (name, ty) <- name_taus ]) + } + + + -- Now emit the residual constraint + ; emitResidualConstraints rhs_tclvl ev_binds_var + name_taus co_vars qtvs bound_theta_vars + wanted_transformed + + -- All done! + ; traceTc "} simplifyInfer/produced residual implication for quantification" $ + vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates + , text "psig_theta =" <+> ppr psig_theta + , text "bound_theta =" <+> pprCoreBinders bound_theta_vars + , text "qtvs =" <+> ppr qtvs + , text "definite_error =" <+> ppr definite_error ] + + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } + -- NB: bound_theta_vars must be fully zonked + where + partial_sigs = filter isPartialSig sigs + +-------------------- +emitResidualConstraints :: TcLevel -> EvBindsVar + -> [(Name, TcTauType)] + -> CoVarSet -> [TcTyVar] -> [EvVar] + -> WantedConstraints -> TcM () +-- Emit the remaining constraints from the RHS. +emitResidualConstraints rhs_tclvl ev_binds_var + name_taus co_vars qtvs full_theta_vars wanteds + | isEmptyWC wanteds + = return () + + | otherwise + = do { wanted_simple <- TcM.liftZonkM $ TcM.zonkSimples (wc_simple wanteds) + ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple + is_mono ct + | Just ct_ev_id <- wantedEvId_maybe ct + = ct_ev_id `elemVarSet` co_vars + | otherwise + = False + -- Reason for the partition: + -- see Note [Emitting the residual implication in simplifyInfer] + +-- Already done by defaultTyVarsAndSimplify +-- ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) + + ; let inner_wanted = wanteds { wc_simple = inner_simple } + ; implics <- if isEmptyWC inner_wanted + then return emptyBag + else do implic1 <- newImplication + return $ unitBag $ + implic1 { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_given_eqs = MaybeGivenEqs + , ic_info = skol_info } + + ; emitConstraints (emptyWC { wc_simple = outer_simple + , wc_impl = implics }) } + where + full_theta = map idType full_theta_vars + skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) + | (name, ty) <- name_taus ] + -- We don't add the quantified variables here, because they are + -- also bound in ic_skols and we want them to be tidied + -- uniformly. + +-------------------- +findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType +-- Given a partial type signature f :: (C a, D a, _) => blah +-- and the inferred constraints (X a, D a, Y a, C a) +-- compute the difference, which is what will fill in the "_" underscore, +-- In this case the diff is (X a, Y a). +findInferredDiff annotated_theta inferred_theta + | null annotated_theta -- Short cut the common case when the user didn't + = return inferred_theta -- write any constraints in the partial signature + | otherwise + = pushTcLevelM_ $ + do { lcl_env <- TcM.getLclEnv + ; given_ids <- mapM TcM.newEvVar annotated_theta + ; wanteds <- newWanteds AnnOrigin inferred_theta + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + given_cts = mkGivens given_loc given_ids + + ; (residual, _) <- runTcS $ + do { _ <- solveSimpleGivens given_cts + ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } + -- NB: There are no meta tyvars fromn this level annotated_theta + -- because we have either promoted them or unified them + -- See `Note [Quantification and partial signatures]` Wrinkle 2 + + ; return (map (box_pred . ctPred) $ + bagToList $ + wc_simple residual) } + where + box_pred :: PredType -> PredType + box_pred pred = case classifyPredType pred of + EqPred rel ty1 ty2 + | Just (cls,tys) <- boxEqPred rel ty1 ty2 + -> mkClassPred cls tys + | otherwise + -> pprPanic "findInferredDiff" (ppr pred) + _other -> pred + +{- Note [Emitting the residual implication in simplifyInfer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = e +where f's type is inferred to be something like (a, Proxy k (Int |> co)) +and we have an as-yet-unsolved, or perhaps insoluble, constraint + [W] co :: Type ~ k +We can't form types like (forall co. blah), so we can't generalise over +the coercion variable, and hence we can't generalise over things free in +its kind, in the case 'k'. But we can still generalise over 'a'. So +we'll generalise to + f :: forall a. (a, Proxy k (Int |> co)) +Now we do NOT want to form the residual implication constraint + forall a. [W] co :: Type ~ k +because then co's eventual binding (which will be a value binding if we +use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose +type mentions 'co'). Instead, just as we don't generalise over 'co', we +should not bury its constraint inside the implication. Instead, we must +put it outside. + +That is the reason for the partitionBag in emitResidualConstraints, +which takes the CoVars free in the inferred type, and pulls their +constraints out. (NB: this set of CoVars should be closed-over-kinds.) + +All rather subtle; see #14584. + +Note [Add signature contexts as wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#11016): + f2 :: (?x :: Int) => _ + f2 = ?x + +or this + class C a b | a -> b + g :: C p q => p -> q + f3 :: C Int b => _ + f3 = g (3::Int) + +We'll use plan InferGen because there are holes in the type. But: + * For f2 we want to have the (?x :: Int) constraint floating around + so that the functional dependencies kick in. Otherwise the + occurrence of ?x on the RHS produces constraint (?x :: alpha), and + we won't unify alpha:=Int. + + * For f3 want the (C Int b) constraint from the partial signature + to meet the (C Int beta) constraint we get from the call to g; again, + fundeps + +Solution: in simplifyInfer, we add the constraints from the signature +as extra Wanteds. + +Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas +that would mess up (GivenInv) in Note [TcLevel invariants]. Consider + f :: (Eq a, _) => blah1 + f = ....g... + g :: (Eq b, _) => blah2 + g = ...f... + +Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with +TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved +all those constraints. And both have level 1, so we can't put them as +Givens when solving at level 1. + +Best to treat them as Wanteds. + +But see also #20076, which would be solved if they were Givens. + + +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [Deciding quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + +* Step 1: decidePromotedTyVars. + Take the global tyvars, and "grow" them using functional dependencies + E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can + happen because alpha is untouchable here) then do not quantify over + beta, because alpha fixes beta, and beta is effectively free in + the environment too; this logic extends to general fundeps, not + just equalities + + We also account for the monomorphism restriction; if it applies, + add the free vars of all the constraints. + + Result is mono_tvs; we will promote all of these to the outer levek, + and certainly not quantify over them. + +* Step 2: defaultTyVarsAndSimplify. + Default any non-promoted tyvars (i.e ones that are definitely + not going to become further constrained), and re-simplify the + candidate constraints. + + Motivation for re-simplification (#7857): imagine we have a + constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are + not free in the envt, and instance forall (a::*) (b::*). (C a) => C + (a -> b) The instance doesn't match while l1,l2 are polymorphic, but + it will match when we default them to LiftedRep. + + This is all very tiresome. + + This step also promotes the mono_tvs from Step 1. See + Note [Promote monomorphic tyvars]. In fact, the *only* + use of the mono_tvs from Step 1 is to promote them here. + This promotion effectively stops us from quantifying over them + later, in Step 3. Because the actual variables to quantify + over are determined in Step 3 (not in Step 1), it is OK for + the mono_tvs to be missing some variables free in the + environment. This is why removing the psig_qtvs is OK in + decidePromotedTyVars. Test case for this scenario: T14479. + +* Step 3: decideQuantifiedTyVars. + Decide which variables to quantify over, as follows: + + - Take the free vars of the partial-type-signature types and constraints, + and the tau-type (zonked_tau_tvs), and then "grow" + them using all the constraints. These are grown_tcvs. + See Note [growThetaTyVars vs closeWrtFunDeps]. + + - Use quantifyTyVars to quantify over the free variables of all the types + involved, but only those in the grown_tcvs. + + Result is qtvs. + +* Step 4: Filter the constraints using pickQuantifiablePreds and the + qtvs. We have to zonk the constraints first, so they "see" the + freshly created skolems. + +Note [Unconditionally resimplify constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke +the solver to simplify the constraints before quantifying them. We do this for +two reasons, enumerated below. We could, in theory, detect when either of these +cases apply and simplify only then, but collecting this information is bothersome, +and simplifying redundantly causes no real harm. Note that this code path +happens only for definitions + * without a type signature + * when -XMonoLocalBinds does not apply + * with unsolved constraints +and so the performance cost will be small. + +1. Defaulting + +Defaulting the variables handled by defaultTyVar may unlock instance simplifications. +Example (typecheck/should_compile/T20584b): + + with (t :: Double) (u :: String) = printf "..." t u + +We know the types of t and u, but we do not know the return type of `with`. So, we +assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is + printf :: PrintfType r => String -> r +The occurrence of printf is instantiated with a fresh var beta. We then get + beta := Double -> String -> alpha +and + [W] PrintfType (Double -> String -> alpha) + +Module Text.Printf exports + instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) +and it looks like that instance should apply. + +But I have elided some key details: (->) is polymorphic over multiplicity and +runtime representation. Here it is in full glory: + [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho)) + instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type)) + +Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance +would have an explicit equality constraint to the left of =>, but that's not what we have.) +Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep. +Yet it's too late to simplify the quantified constraint, and thus GHC infers + wait :: PrintfType (Double -> String -> t) => Double -> String -> t +which is silly. Simplifying again after defaulting solves this problem. + +2. Interacting functional dependencies + +Suppose we have + + class C a b | a -> b + +and we are running simplifyInfer over + + forall[2] x. () => [W] C a beta1[1] + forall[2] y. () => [W] C a beta2[1] + +These are two implication constraints, both of which contain a +wanted for the class C. Neither constraint mentions the bound +skolem. We might imagine that these constraints could thus float +out of their implications and then interact, causing beta1 to unify +with beta2, but constraints do not currently float out of implications. + +Unifying the beta1 and beta2 is important. Without doing so, then we might +infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the +ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as +required by the fundep interactions. This happens in the parsec library, and +in test case typecheck/should_compile/FloatFDs. + +If we re-simplify, however, the two fundep constraints will interact, causing +a unification between beta1 and beta2, and all will be well. The key step +is that this simplification happens *after* the call to approximateWC in +simplifyInfer. + +-} + +decideQuantification + :: SkolemInfo + -> InferMode + -> TcLevel + -> [(Name, TcTauType)] -- Variables to be generalised + -> [TcIdSigInst] -- Partial type signatures (if any) + -> [PredType] -- Candidate theta; already zonked + -> TcM ( [TcTyVar] -- Quantify over these (skolems) + , [PredType] -- and this context (fully zonked) + , CoVarSet) +-- See Note [Deciding quantification] +decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates + = do { -- Step 1: find the mono_tvs + ; (candidates, co_vars, mono_tvs0) + <- decidePromotedTyVars infer_mode name_taus psigs candidates + + -- Step 2: default any non-mono tyvars, and re-simplify + -- This step may do some unification, but result candidates is zonked + ; candidates <- defaultTyVarsAndSimplify rhs_tclvl candidates + + -- Step 3: decide which kind/type variables to quantify over + ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates + + -- Step 4: choose which of the remaining candidate + -- predicates to actually quantify over + -- NB: decideQuantifiedTyVars turned some meta tyvars + -- into quantified skolems, so we have to zonk again + ; (candidates, psig_theta) <- TcM.liftZonkM $ + do { candidates <- TcM.zonkTcTypes candidates + ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) + ; return (candidates, psig_theta) } + ; min_theta <- pickQuantifiablePreds (mkVarSet qtvs) mono_tvs0 candidates + + -- Take account of partial type signatures + -- See Note [Constraints in partial type signatures] + ; let min_psig_theta = mkMinimalBySCs id psig_theta + ; theta <- if + | null psigs -> return min_theta -- Case (P3) + | not (all has_extra_constraints_wildcard psigs) -- Case (P2) + -> return min_psig_theta + | otherwise -- Case (P1) + -> do { diff <- findInferredDiff min_psig_theta min_theta + ; return (min_psig_theta ++ diff) } + + ; traceTc "decideQuantification" + (vcat [ text "infer_mode:" <+> ppr infer_mode + , text "candidates:" <+> ppr candidates + , text "psig_theta:" <+> ppr psig_theta + , text "co_vars:" <+> ppr co_vars + , text "qtvs:" <+> ppr qtvs + , text "theta:" <+> ppr theta ]) + ; return (qtvs, theta, co_vars) } + + where + has_extra_constraints_wildcard (TISI { sig_inst_wcx = Just {} }) = True + has_extra_constraints_wildcard _ = False + +{- Note [Constraints in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have decided to quantify over min_theta, say (Eq a, C a, Ix a). +Then we distinguish three cases: + +(P1) No partial type signatures: just quantify over min_theta + +(P2) Partial type signatures with no extra_constraints wildcard: + e.g. f :: (Eq a, C a) => a -> _ + Quantify over psig_theta: the user has explicitly specified the + entire context. + + That may mean we have an unsolved residual constraint (Ix a) arising + from the RHS of the function. But so be it: the user said (Eq a, C a). + +(P3) Partial type signature with an extra_constraints wildcard. + e.g. f :: (Eq a, C a, _) => a -> a + Quantify over (psig_theta ++ diff) + where diff = min_theta - psig_theta, using findInferredDiff. + In our example, diff = Ix a + +Some rationale and observations + +* See Note [When the MR applies] in GHC.Tc.Gen.Bind. + +* We always want to quantify over psig_theta (if present). The user specified + it! And pickQuantifiableCandidates might have dropped some + e.g. CallStack constraints. c.f #14658 + equalities (a ~ Bool) + +* In case (P3) we ask that /all/ the signatures have an extra-constraints + wildcard. It's a bit arbitrary; not clear what the "right" thing is. + +* In (P2) we encounter #20076: + f :: Eq [a] => a -> _ + f x = [x] == [x] + From the RHS we get [W] Eq [a]. We simplify those Wanteds in simplifyInfer, + to get (Eq a). But then we quantify over the user-specified (Eq [a]), leaving + a residual implication constraint (forall a. Eq [a] => [W] Eq a), which is + insoluble. Idea: in simplifyInfer we could put the /un-simplified/ constraints + in the residual -- at least in the case like #20076 where the partial signature + fully specifies the final constraint. Maybe: a battle for another day. + +* It's helpful to use the same "find difference" algorithm, `findInferredDiff`, + here as we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) + + At least for single functions we would like to quantify f over precisely the + same theta as , so that we get to take the short-cut path in + `GHC.Tc.Gen.Bind.mkExport`, and avoid calling `tcSubTypeSigma` for impedance + matching. Why avoid? Because it falls over for ambiguous types (#20921). + + We can get precisely the same theta by using the same algorithm, + `findInferredDiff`. + +* All of this goes wrong if we have (a) mutual recursion, (b) multiple + partial type signatures, (c) with different constraints, and (d) + ambiguous types. Something like + f :: forall a. Eq a => F a -> _ + f x = (undefined :: a) == g x undefined + g :: forall b. Show b => F b -> _ -> b + g x y = let _ = (f y, show x) in x + But that's a battle for another day. +-} + +decidePromotedTyVars :: InferMode + -> [(Name,TcType)] + -> [TcIdSigInst] + -> [PredType] + -> TcM ([PredType], CoVarSet, TcTyVarSet) +-- We are about to generalise over type variables at level N +-- Each must be either +-- (P) promoted +-- (D) defaulted +-- (Q) quantified +-- This function finds (P), the type variables that we are going to promote: +-- (a) Mentioned in a constraint we can't generalise (the MR) +-- (b) Mentioned in the kind of a CoVar; we can't quantify over a CoVar, +-- so we must not quantify over a type variable free in its kind +-- (c) Connected by an equality or fundep to +-- * a type variable at level < N, or +-- * A tyvar subject to (a), (b) or (c) +-- Having found all such level-N tyvars that we can't generalise, +-- promote them, to eliminate them from further consideration. +-- +-- Also return CoVars that appear free in the final quantified types +-- we can't quantify over these, and we must make sure they are in scope +decidePromotedTyVars infer_mode name_taus psigs candidates + = do { tc_lvl <- TcM.getTcLevel + ; (no_quant, maybe_quant) <- pick infer_mode candidates + + -- 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, psig_theta, taus) <- TcM.liftZonkM $ + do { psig_qtvs <- zonkTcTyVarsToTcTyVars $ binderVars $ + concatMap (map snd . sig_inst_skols) psigs + ; psig_theta <- mapM TcM.zonkTcType $ + concatMap sig_inst_theta psigs + ; taus <- mapM (TcM.zonkTcType . snd) name_taus + ; return (psig_qtvs, psig_theta, taus) } + + ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta + + -- (b) The co_var_tvs are tvs mentioned in the types of covars or + -- coercion holes. We can't quantify over these covars, so we + -- must include the variable in their types in the mono_tvs. + -- E.g. If we can't quantify over co :: k~Type, then we can't + -- quantify over k either! Hence closeOverKinds + -- Recall that coVarsOfTypes also returns coercion holes + co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates) + co_var_tvs = closeOverKinds co_vars + + mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ + tyCoVarsOfTypes candidates + -- We need to grab all the non-quantifiable tyvars in the + -- types so that we can grow this set to find other + -- non-quantifiable tyvars. This can happen with something like + -- f x y = ... + -- where z = x 3 + -- The body of z tries to unify the type of x (call it alpha[1]) + -- with (beta[2] -> gamma[2]). This unification fails because + -- alpha is untouchable, leaving [W] alpha[1] ~ (beta[2] -> gamma[2]). + -- We need to know not to quantify over beta or gamma, because they + -- are in the equality constraint with alpha. Actual test case: + -- typecheck/should_compile/tc213 + + mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs + + -- mono_tvs1 is now the set of variables from an outer scope + -- (that's mono_tvs0) and the set of covars, closed over kinds. + -- Given this set of variables we know we will not quantify, + -- we want to find any other variables that are determined by this + -- set, by functional dependencies or equalities. We thus use + -- closeWrtFunDeps to find all further variables determined by this root + -- set. See Note [growThetaTyVars vs closeWrtFunDeps] + + non_ip_candidates = filterOut isIPLikePred candidates + -- implicit params don't really determine a type variable + -- (that is, we might have IP "c" Bool and IP "c" Int in different + -- places within the same program), and + -- skipping this causes implicit params to monomorphise too many + -- variables; see Note [Inheriting implicit parameters] in GHC.Tc.Solver. + -- Skipping causes typecheck/should_compile/tc219 to fail. + + mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1 + -- mono_tvs2 now contains any variable determined by the "root + -- set" of monomorphic tyvars in mono_tvs1. + + constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ + closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant) + `minusVarSet` mono_tvs2 + -- constrained_tvs: the tyvars that we are not going to + -- quantify /solely/ because of the monomorphism restriction + -- + -- (`minusVarSet` mono_tvs2): a type variable is only + -- "constrained" (so that the MR bites) if it is not + -- free in the environment (#13785) or is determined + -- by some variable that is free in the env't + + mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs) + `delVarSetList` psig_qtvs + -- (`delVarSetList` psig_qtvs): if the user has explicitly + -- asked for quantification, then that request "wins" + -- over the MR. + -- + -- What if a psig variable is also free in the environment + -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation + -- in Step 2 of Note [Deciding quantification]. + + -- Warn about the monomorphism restriction + ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do + let dia = TcRnMonomorphicBindings (map fst name_taus) + diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia + + -- Promote the mono_tvs: see Note [Promote monomorphic tyvars] + ; _ <- promoteTyVarSet mono_tvs + + ; traceTc "decidePromotedTyVars" $ vcat + [ text "infer_mode =" <+> ppr infer_mode + , text "psigs =" <+> ppr psigs + , text "psig_qtvs =" <+> ppr psig_qtvs + , text "mono_tvs0 =" <+> ppr mono_tvs0 + , text "no_quant =" <+> ppr no_quant + , text "maybe_quant =" <+> ppr maybe_quant + , text "mono_tvs =" <+> ppr mono_tvs + , text "co_vars =" <+> ppr co_vars ] + + ; return (maybe_quant, co_vars, mono_tvs0) } + where + pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) + -- Split the candidates into ones we definitely + -- won't quantify, and ones that we might + pick ApplyMR cand = return (cand, []) + pick NoRestrictions cand = return ([], cand) + pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings + ; return (partition (is_int_ct os) cand) } + + -- is_int_ct returns True for a constraint we should /not/ quantify + -- For EagerDefaulting, do not quantify over + -- over any interactive class constraint + is_int_ct ovl_strings pred + = case classifyPredType pred of + ClassPred cls _ -> isInteractiveClass ovl_strings cls + _ -> False + +------------------- +defaultTyVarsAndSimplify :: TcLevel + -> [PredType] -- Assumed zonked + -> TcM [PredType] -- Guaranteed zonked +-- Default any tyvar free in the constraints; +-- and re-simplify in case the defaulting allows further simplification +defaultTyVarsAndSimplify rhs_tclvl candidates + = do { -- Default any kind/levity vars + ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} + <- candidateQTyVarsOfTypes candidates + -- NB1: decidePromotedTyVars has promoted any type variable fixed by the + -- type envt, so they won't be chosen by candidateQTyVarsOfTypes + -- NB2: Defaulting for variables free in tau_tys is done later, by quantifyTyVars + -- Hence looking only at 'candidates' + -- NB3: Any covars should already be handled by + -- the logic in decidePromotedTyVars, which looks at + -- the constraints generated + + ; poly_kinds <- xoptM LangExt.PolyKinds + ; let default_kv | poly_kinds = default_tv + | otherwise = defaultTyVar DefaultKindVars + default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars) + ; mapM_ default_kv (dVarSetElems cand_kvs) + ; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) + + ; simplify_cand candidates + } + where + -- See Note [Unconditionally resimplify constraints when quantifying] + simplify_cand [] = return [] -- Fast path + simplify_cand candidates + = do { clone_wanteds <- newWanteds DefaultOrigin candidates + ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ + simplifyWantedsTcM clone_wanteds + -- Discard evidence; simples is fully zonked + + ; let new_candidates = ctsPreds simples + ; traceTc "Simplified after defaulting" $ + vcat [ text "Before:" <+> ppr candidates + , text "After:" <+> ppr new_candidates ] + ; return new_candidates } + +------------------ +decideQuantifiedTyVars + :: SkolemInfo + -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs + -> [TcIdSigInst] -- Partial signatures + -> [PredType] -- Candidates, zonked + -> TcM [TyVar] +-- Fix what tyvars we are going to quantify over, and quantify them +decideQuantifiedTyVars skol_info name_taus psigs candidates + = do { -- Why psig_tys? We try to quantify over everything free in here + -- See Note [Quantification and partial signatures] + -- Wrinkles 2 and 3 + ; (psig_tv_tys, psig_theta, tau_tys) <- TcM.liftZonkM $ + do { psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs + , (_,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 + ; return (psig_tv_tys, psig_theta, tau_tys) } + + ; let -- Try to quantify over variables free in these types + psig_tys = psig_tv_tys ++ psig_theta + seed_tys = psig_tys ++ tau_tys + + -- Now "grow" those seeds to find ones reachable via 'candidates' + -- See Note [growThetaTyVars vs closeWrtFunDeps] + grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) + + -- Now we have to classify them into kind variables and type variables + -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars + -- + -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces + -- them in that order, so that the final qtvs quantifies in the same + -- order as the partial signatures do (#13524) + ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ + psig_tys ++ candidates ++ tau_tys + ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) + dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } + + ; traceTc "decideQuantifiedTyVars" (vcat + [ text "tau_tys =" <+> ppr tau_tys + , text "candidates =" <+> ppr candidates + , text "cand_kvs =" <+> ppr cand_kvs + , text "cand_tvs =" <+> ppr cand_tvs + , text "tau_tys =" <+> ppr tau_tys + , text "seed_tys =" <+> ppr seed_tys + , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) + , text "grown_tcvs =" <+> ppr grown_tcvs + , text "dvs =" <+> ppr dvs_plus]) + + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } + +------------------ +-- | When inferring types, should we quantify over a given predicate? +-- See Note [pickQuantifiablePreds] +pickQuantifiablePreds + :: TyVarSet -- Quantifying over these + -> TcTyVarSet -- mono_tvs0: variables mentioned a candidate + -- constraint that come from some outer level + -> TcThetaType -- Proposed constraints to quantify + -> TcM TcThetaType -- A subset that we can actually quantify +-- This function decides whether a particular constraint should be +-- quantified over, given the type variables that are being quantified +pickQuantifiablePreds qtvs mono_tvs0 theta + = do { tc_lvl <- TcM.getTcLevel + ; let is_nested = not (isTopTcLevel tc_lvl) + ; return (mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] + mapMaybe (pick_me is_nested) theta) } + where + pick_me is_nested pred + = let pred_tvs = tyCoVarsOfType pred + mentions_qtvs = pred_tvs `intersectsVarSet` qtvs + in case classifyPredType pred of + + ClassPred cls tys + | Just {} <- isCallStackPred cls tys + -- NEVER infer a CallStack constraint. Otherwise we let + -- the constraints bubble up to be solved from the outer + -- context, or be defaulted when we reach the top-level. + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + -> Nothing + + | isIPClass cls + -> Just pred -- See Note [Inheriting implicit parameters] + + | not mentions_qtvs + -> Nothing -- Don't quantify over predicates that don't + -- mention any of the quantified type variables + + | is_nested + -> Just pred + + -- From here on, we are thinking about top-level defns only + + | pred_tvs `subVarSet` (qtvs `unionVarSet` mono_tvs0) + -- See Note [Do not quantify over constraints that determine a variable] + -> Just pred + + | otherwise + -> Nothing + + EqPred eq_rel ty1 ty2 + | mentions_qtvs + , quantify_equality eq_rel ty1 ty2 + , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 + -- boxEqPred: See Note [Lift equality constraints when quantifying] + -> Just (mkClassPred cls tys) + | otherwise + -> Nothing + + IrredPred {} | mentions_qtvs -> Just pred + | otherwise -> Nothing + + ForAllPred {} -> Nothing + + -- See Note [Quantifying over equality constraints] + quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 + quantify_equality ReprEq _ _ = True + + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isTypeFamilyTyCon tc + -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + +------------------ +growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet +-- See Note [growThetaTyVars vs closeWrtFunDeps] +growThetaTyVars theta tcvs + | null theta = tcvs + | otherwise = transCloVarSet mk_next seed_tcvs + where + seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips + (ips, non_ips) = partition isIPLikePred theta + -- See Note [Inheriting implicit parameters] + + mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones + mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips + grow_one so_far pred tcvs + | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs + | otherwise = tcvs + where + pred_tcvs = tyCoVarsOfType pred + + +{- Note [Promote monomorphic tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Promote any type variables that are free in the environment. Eg + f :: forall qtvs. bound_theta => zonked_tau +The free vars of f's type become free in the envt, and hence will show +up whenever 'f' is called. They may currently at rhs_tclvl, but they +had better be unifiable at the outer_tclvl! Example: envt mentions +alpha[1] + tau_ty = beta[2] -> beta[2] + constraints = alpha ~ [beta] +we don't quantify over beta (since it is fixed by envt) +so we must promote it! The inferred type is just + f :: beta -> beta + +NB: promoteTyVarSet ignores coercion variables + +Note [pickQuantifiablePreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pickQuantifiablePreds is called we have decided what type +variables to quantify over, `qtvs`. The only quesion is: which of the +unsolved candidate predicates should we quantify over? Call them +`picked_theta`. + +Note that will leave behind a residual implication + forall qtvs. picked_theta => unsolved_constraints +For the members of unsolved_constraints that we select for picked_theta +it is easy to solve, by identity. For the others we just hope that +we can solve them. + +So which of the candidates should we pick to quantify over? In some +situations we distinguish top-level from nested bindings. The point +about nested binding is that + (a) the types may mention type variables free in the environment + (b) all of the call sites are statically visible, reducing the + worries about "spooky action at a distance". + +First, never pick a constraint that doesn't mention any of the quantified +variables `qtvs`. Picking such a constraint essentially moves the solving of +the constraint from this function definition to call sites. But because the +constraint mentions no quantified variables, call sites have no advantage +over the definition site. Well, not quite: there could be new constraints +brought into scope by a pattern-match against a constrained (e.g. GADT) +constructor. Example + + data T a where { T1 :: T1 Bool; ... } + + f :: forall a. a -> T a -> blah + f x t = let g y = x&&y -- This needs a~Bool + in case t of + T1 -> g True + .... + +At g's call site we have `a~Bool`, so we /could/ infer + g :: forall . (a~Bool) => Bool -> Bool -- qtvs = {} + +This is all very contrived, and probably just postponse type errors to +the call site. If that's what you want, write a type signature. + +Actually, implicit parameters is an exception to the "no quantified vars" +rule (see Note [Inheriting implicit parameters]) so we can't actually +simply test this case first. + +Now we consider the different sorts of constraints: + +* For ClassPred constraints: + + * Never pick a CallStack constraint. + See Note [Overview of implicit CallStacks] + + * Always pick an implicit-parameter constraint. + Note [Inheriting implicit parameters] + + * For /top-level/ class constraints see + Note [Do not quantify over constraints that determine a variable] + +* For EqPred constraints see Note [Quantifying over equality constraints] + +* For IrredPred constraints, we allow anything that mentions the quantified + type variables. + +* A ForAllPred should not appear: the candidates come from approximateWC. + +Notice that we do /not/ consult -XFlexibleContexts here. For example, +we allow `pickQuantifiablePreds` to quantify over a constraint like +`Num [a]`; then if we don't have `-XFlexibleContexts` we'll get an +error from `checkValidType` but (critically) it includes the helpful +suggestion of adding `-XFlexibleContexts`. See #10608, #10351. + +Note [Lift equality constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't quantify over a constraint (t1 ~# t2) because that isn't a +predicate type; see Note [Types for coercions, predicates, and evidence] +in GHC.Core.TyCo.Rep. + +So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted +to Coercible. + +This tiresome lifting is the reason that pick_me (in +pickQuantifiablePreds) returns a Maybe rather than a Bool. + +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See pickQuantifiablePreds. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t) +in pickQuantifiablePreds? + +* It is always /sound/ to quantify over a constraint -- those + quantified constraints will need to be proved at each call site. + +* We definitely don't want to quantify over (Maybe a ~ Bool), to get + f :: forall a. (Maybe a ~ Bool) => blah + That simply postpones a type error from the function definition site to + its call site. Fortunately we have already filtered out insoluble + constraints: see `definite_error` in `simplifyInfer`. + +* What about (a ~ T alpha b), where we are about to quantify alpha, `a` and + `b` are in-scope skolems, and `T` is a data type. It's pretty unlikely + that this will be soluble at a call site, so we don't quantify over it. + +* What about `(F beta ~ Int)` where we are going to quantify `beta`? + Should we quantify over the (F beta ~ Int), to get + f :: forall b. (F b ~ Int) => blah + Aha! Perhaps yes, because at the call site we will instantiate `b`, and + perhaps we have `instance F Bool = Int`. So we *do* quantify over a + type-family equality where the arguments mention the quantified variables. + +This is all a bit ad-hoc. + +Note [Do not quantify over constraints that determine a variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/tc231), where we're trying to infer +the type of a top-level declaration. We have + class Zork s a b | a -> b +and the candidate constraint at the end of simplifyInfer is + [W] Zork alpha[1] (Z [Char]) beta[1] +We definitely want to quantify over `alpha` (which is mentioned in the +tau-type). + +But we do *not* want to quantify over `beta`: it is determined by the +functional dependency on Zork: note that the second argument to Zork +in the Wanted is a variable-free `Z [Char]`. Quantifying over it +would be "Henry Ford polymorphism". (Presumably we don't have an +instance in scope that tells us what `beta` actually is.) Instead +we promote `beta[1]` to `beta[0]`, in `decidePromotedTyVars`. + +The question here: do we want to quantify over the constraint, to +give the type + forall a. Zork a (Z [Char]) beta[0] => blah +Definitely not. Since we're not quantifying over beta, it has been +promoted; and then will be zapped to Any in the final zonk. So we end +up with a (perhaps exported) type involving + forall a. Zork a (Z [Char]) Any => blah +No no no: + + Key principle: we never want to show the programmer + a type with `Any` in it. + +What we really want (to catch the Zork example) is this: + + Quantify over the constraint only if all its free variables are + (a) quantified, or + (b) appears in the type of something in the environment (mono_tvs0). + +To understand (b) consider + + class C a b where { op :: a -> b -> () } + + mr = 3 -- mr :: alpha + f1 x = op x mr -- f1 :: forall b. b -> (), plus [W] C b alpha + intify = mr + (4 :: Int) + +In `f1` should we quantify over that `(C b alpha)`? Answer: since `alpha` +is free in the type envt, yes we should. After all, if we'd typechecked +`intify` first, we'd have set `alpha := Int`, and /then/ we'd certainly +quantify. The delicate Zork situation applies when beta is completely +unconstrained (not free in the environment) -- except by the fundep. + +Another way to put it: let's say `alpha` is in `mono_tvs0`. It must be that +some variable `x` has `alpha` free in its type. If we are at top-level (and we +are, because nested decls don't go through this path all), then `x` must also +be at top-level. And, by induction, `x` will not have Any in its type when all +is said and done. The induction is well-founded because, if `x` is mutually +recursive with the definition at hand, then their constraints get processed +together (or `x` has a type signature, in which case the type doesn't have +`Any`). So the key thing is that we must not introduce a new top-level +unconstrained variable here. + +However this regrettably-subtle reasoning is needed only for /top-level/ +declarations. For /nested/ decls we can see all the calls, so we'll +instantiate that quantifed `Zork a (Z [Char]) beta` constraint at call sites, +and either solve it or not (probably not). We won't be left with a +still-callable function with Any in its type. So for nested definitions we +don't make this tricky test. + +Historical note: we had a different, and more complicated test +before, but it was utterly wrong: #23199. + +Note [Quantification and partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When choosing type variables to quantify, the basic plan is to +quantify over all type variables that are + * free in the tau_tvs, and + * not forced to be monomorphic (mono_tvs), + for example by being free in the environment. + +However, in the case of a partial type signature, we are doing inference +*in the presence of a type signature*. For example: + f :: _ -> a + f x = ... +or + g :: (Eq _a) => _b -> _b +In both cases we use plan InferGen, and hence call simplifyInfer. But +those 'a' variables are skolems (actually TyVarTvs), and we should be +sure to quantify over them. This leads to several wrinkles: + +* Wrinkle 1. In the case of a type error + f :: _ -> Maybe a + f x = True && x + The inferred type of 'f' is f :: Bool -> Bool, but there's a + left-over error of form (Maybe a ~ Bool). The error-reporting + machine expects to find a binding site for the skolem 'a', so we + add it to the quantified tyvars. + +* Wrinkle 2. Consider the partial type signature + f :: (Eq _) => Int -> Int + f x = x + In normal cases that makes sense; e.g. + g :: Eq _a => _a -> _a + g x = x + where the signature makes the type less general than it could + be. But for 'f' we must therefore quantify over the user-annotated + constraints, to get + f :: forall a. Eq a => Int -> Int + (thereby correctly triggering an ambiguity error later). If we don't + we'll end up with a strange open type + f :: Eq alpha => Int -> Int + which isn't ambiguous but is still very wrong. + + Bottom line: Try to quantify over any variable free in psig_theta, + just like the tau-part of the type. + +* Wrinkle 3 (#13482). Also consider + f :: forall a. _ => Int -> Int + f x = if (undefined :: a) == undefined then x else 0 + Here we get an (Eq a) constraint, but it's not mentioned in the + psig_theta nor the type of 'f'. But we still want to quantify + over 'a' even if the monomorphism restriction is on. + +* Wrinkle 4 (#14479) + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + In the signature for 'g', we cannot quantify over 'b' because it turns out to + get unified with 'a', which is free in g's environment. So we carefully + refrain from bogusly quantifying, in GHC.Tc.Solver.decidePromotedTyVars. We + report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Note [growThetaTyVars vs closeWrtFunDeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with +the same type and similar behavior. This Note outlines the differences +and why we use one or the other. + +Both functions take a list of constraints. We will call these the +*candidates*. + +closeWrtFunDeps takes a set of "determined" type variables and finds the +closure of that set with respect to the functional dependencies +within the class constraints in the set of candidates. So, if we +have + + class C a b | a -> b + class D a b -- no fundep + candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)} + +then closeWrtFunDeps {a} will return the set {a,b,c}. +This is because, if `a` is determined, then `b` and `c` are, too, +by functional dependency. closeWrtFunDeps called with any seed set not including +`a` will just return its argument, as only `a` determines any other +type variable (in this example). + +growThetaTyVars operates similarly, but it behaves as if every +constraint has a functional dependency among all its arguments. +So, continuing our example, growThetaTyVars {a} will return +{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of +variables to include all variables that are mentioned in the same +constraint (transitively). + +We use closeWrtFunDeps in places where we need to know which variables are +*always* determined by some seed set. This includes + * when determining the mono-tyvars in decidePromotedTyVars. If `a` + is going to be monomorphic, we need b and c to be also: they + are determined by the choice for `a`. + * when checking instance coverage, in + GHC.Tc.Instance.FunDeps.checkInstCoverage + +On the other hand, we use growThetaTyVars where we need to know +which variables *might* be determined by some seed set. This includes + * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers + and decideQuantifiedTyVars +How can `a` determine (say) `d` in the example above without a fundep? +Suppose we have + instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c) +Now, if `a` turns out to be a list, it really does determine b and c. +The danger in overdoing quantification is the creation of an ambiguous +type signature, but this is conveniently caught in the validity checker. + +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints (including especially "variable not in scope"), we + +* Abandon all attempts to find a context to quantify over, + and instead make the function fully-polymorphic in whatever + type we have found + +* Return a flag from simplifyInfer, indicating that we found an + insoluble constraint. This flag is used to suppress the ambiguity + check for the inferred type, which may well be bogus, and which + tends to obscure the real error. This fix feels a bit clunky, + but I failed to come up with anything better. + +Reasons: + - Avoid downstream errors + - Do not perform an ambiguity test on a bogus type, which might well + fail spuriously, thereby obfuscating the original insoluble error. + #14000 is an example + +I tried an alternative approach: simply failM, after emitting the +residual implication constraint; the exception will be caught in +GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type +(forall a. a). But that didn't work with -fdefer-type-errors, because +the recovery from failM emits no code at all, so there is no function +to run! But -fdefer-type-errors aspires to produce a runnable program. + +Note [Default while Inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our current plan is that defaulting only happens at simplifyTop and +not simplifyInfer. This may lead to some insoluble deferred constraints. +Example: + +instance D g => C g Int b + +constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha +type inferred = gamma -> gamma + +Now, if we try to default (alpha := Int) we will be able to refine the implication to + (forall b. 0 => C gamma Int b) +which can then be simplified further to + (forall b. 0 => D gamma) +Finally, we /can/ approximate this implication with (D gamma) and infer the quantified +type: forall g. D g => g -> g + +Instead what will currently happen is that we will get a quantified type +(forall g. g -> g) and an implication: + forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha + +Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an +unsolvable implication: + forall g. 0 => (forall b. 0 => D g) + +The concrete example would be: + h :: C g a s => g -> a -> ST s a + f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) + +But it is quite tedious to do defaulting and resolve the implication constraints, and +we have not observed code breaking because of the lack of defaulting in inference, so +we don't do it for now. + + + +Note [Minimize by Superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we quantify over a constraint, in simplifyInfer we need to +quantify over a constraint that is minimal in some sense: For +instance, if the final wanted constraint is (Eq alpha, Ord alpha), +we'd like to quantify over Ord alpha, because we can just get Eq alpha +from superclass selection from Ord alpha. This minimization is what +mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint +to check the original wanted. + + +Note [Avoid unnecessary constraint simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -------- NB NB NB (Jun 12) ------------- + This note not longer applies; see the notes with #4361. + But I'm leaving it in here so we remember the issue.) + ---------------------------------------- +When inferring the type of a let-binding, with simplifyInfer, +try to avoid unnecessarily simplifying class constraints. +Doing so aids sharing, but it also helps with delicate +situations like + + instance C t => C [t] where .. + + f :: C [t] => .... + f x = let g y = ...(constraint C [t])... + in ... +When inferring a type for 'g', we don't want to apply the +instance decl, because then we can't satisfy (C t). So we +just notice that g isn't quantified over 't' and partition +the constraints before simplifying. + +This only half-works, but then let-generalisation only half-works. + +********************************************************************************* +* * +* Main Simplifier * +* * +*********************************************************************************** + +-} + +simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints +-- Solve the specified Wanted constraints +-- Discard the evidence binds +-- Postcondition: fully zonked +simplifyWantedsTcM wanted + = do { traceTc "simplifyWantedsTcM {" (ppr wanted) + ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) + ; result <- TcM.liftZonkM $ TcM.zonkWC result + ; traceTc "simplifyWantedsTcM }" (ppr result) + ; return result } + +solveWanteds :: WantedConstraints -> TcS WantedConstraints +solveWanteds wc@(WC { wc_errors = errs }) + | isEmptyWC wc -- Fast path + = return wc + | otherwise + = do { cur_lvl <- TcS.getTcLevel + ; traceTcS "solveWanteds {" $ + vcat [ text "Level =" <+> ppr cur_lvl + , ppr wc ] + + ; dflags <- getDynFlags + ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc + + ; errs' <- simplifyDelayedErrors errs + ; let final_wc = solved_wc { wc_errors = errs' } + + ; ev_binds_var <- getTcEvBindsVar + ; bb <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveWanteds }" $ + vcat [ text "final wc =" <+> ppr final_wc + , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] + + ; return final_wc } + +simplify_loop :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +-- Do a round of solving, and call maybe_simplify_again to iterate +-- The 'definitely_redo_implications' flags is False if the only reason we +-- are iterating is that we have added some new Wanted superclasses +-- hoping for fundeps to help us; see Note [Superclass iteration] +-- +-- Does not affect wc_holes at all; reason: wc_holes never affects anything +-- else, so we do them once, at the end in solveWanteds +simplify_loop n limit definitely_redo_implications + wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { csTraceTcS $ + text "simplify_loop iteration=" <> int n + <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma + , int (lengthBag simples) <+> text "simples to solve" ]) + ; traceTcS "simplify_loop: wc =" (ppr wc) + + ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration] + solveSimpleWanteds simples + -- Any insoluble constraints are in 'simples' and so get rewritten + -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet + + ; wc2 <- if not definitely_redo_implications -- See Note [Superclass iteration] + && unifs1 == 0 -- for this conditional + && isEmptyBag (wc_impl wc1) + then return (wc { wc_simple = wc_simple wc1 }) -- Short cut + else do { implics2 <- solveNestedImplications $ + implics `unionBags` (wc_impl wc1) + ; return (wc { wc_simple = wc_simple wc1 + , wc_impl = implics2 }) } + + ; unif_happened <- resetUnificationFlag + ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened + -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad + ; maybe_simplify_again (n+1) limit unif_happened wc2 } + +maybe_simplify_again :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) + | n `intGtLimit` limit + = do { -- Add an error (not a warning) if we blow the limit, + -- Typically if we blow the limit we are going to report some other error + -- (an unsolved constraint), and we don't want that error to suppress + -- the iteration limit warning! + addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc + ; return wc } + + | unif_happened + = simplify_loop n limit True wc + + | superClassesMightHelp wc + = -- We still have unsolved goals, and apparently no way to solve them, + -- so try expanding superclasses at this level, both Given and Wanted + do { pending_given <- getPendingGivenScs + ; let (pending_wanted, simples1) = getPendingWantedScs simples + ; if null pending_given && null pending_wanted + then return wc -- After all, superclasses did not help + else + do { new_given <- makeSuperClasses pending_given + ; new_wanted <- makeSuperClasses pending_wanted + ; solveSimpleGivens new_given -- Add the new Givens to the inert set + ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given + , text "new_given" <+> ppr new_given + , text "pending_wanted" <+> ppr pending_wanted + , text "new_wanted" <+> ppr new_wanted ]) + ; simplify_loop n limit (not (null pending_given)) $ + wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } + -- (not (null pending_given)): see Note [Superclass iteration] + + | otherwise + = return wc + +{- Note [Superclass iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this implication constraint + forall a. + [W] d: C Int beta + forall b. blah +where + class D a b | a -> b + class D a b => C a b +We will expand d's superclasses, giving [W] D Int beta, in the hope of geting +fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), +and if so it seems a pity to waste time iterating the implications (forall b. blah) +(If we add new Given superclasses it's a different matter: it's really worth looking +at the implications.) + +Hence the definitely_redo_implications flag to simplify_loop. It's usually +True, but False in the case where the only reason to iterate is new Wanted +superclasses. In that case we check whether the new Wanteds actually led to +any new unifications, and iterate the implications only if so. +-} + +{- Note [Expanding Recursive Superclasses and ExpansionFuel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the class declaration (T21909) + + class C [a] => C a where + foo :: a -> Int + +and suppose during type inference we obtain an implication constraint: + + forall a. C a => C [[a]] + +To solve this implication constraint, we first expand one layer of the superclass +of Given constraints, but not for Wanted constraints. +(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help] +in GHC.Tc.Solver.Dict.) We thus get: + + [G] g1 :: C a + [G] g2 :: C [a] -- new superclass layer from g1 + [W] w1 :: C [[a]] + +Now, we cannot solve `w1` directly from `g1` or `g2` as we may not have +any instances for C. So we expand a layer of superclasses of each Wanteds and Givens +that we haven't expanded yet. +This is done in `maybe_simplify_again`. And we get: + + [G] g1 :: C a + [G] g2 :: C [a] + [G] g3 :: C [[a]] -- new superclass layer from g2, can solve w1 + [W] w1 :: C [[a]] + [W] w2 :: C [[[a]]] -- new superclass layer from w1, not solvable + +Now, although we can solve `w1` using `g3` (obtained from expanding `g2`), +we have a new wanted constraint `w2` (obtained from expanding `w1`) that cannot be solved. +We thus make another go at solving in `maybe_simplify_again` by expanding more +layers of superclasses. This looping is futile as Givens will never be able to catch up with Wanteds. + +Side Note: In principle we don't actually need to /solve/ `w2`, as it is a superclass of `w1` +but we only expand it to expose any functional dependencies (see Note [The superclass story]) +But `w2` is a wanted constraint, so we will try to solve it like any other, +even though ultimately we will discard its evidence. + +Solution: Simply bound the maximum number of layers of expansion for +Givens and Wanteds, with ExpansionFuel. Give the Givens more fuel +(say 3 layers) than the Wanteds (say 1 layer). Now the Givens will +win. The Wanteds don't need much fuel: we are only expanding at all +to expose functional dependencies, and wantedFuel=1 means we will +expand a full recursive layer. If the superclass hierarchy is +non-recursive (the normal case) one layer is therefore full expansion. + +The default value for wantedFuel = Constants.max_WANTEDS_FUEL = 1. +The default value for givenFuel = Constants.max_GIVENS_FUEL = 3. +Both are configurable via the `-fgivens-fuel` and `-fwanteds-fuel` +compiler flags. + +There are two preconditions for the default fuel values: + (1) default givenFuel >= default wantedsFuel + (2) default givenFuel < solverIterations + +Precondition (1) ensures that we expand givens at least as many times as we expand wanted constraints +preferably givenFuel > wantedsFuel to avoid issues like T21909 while +the precondition (2) ensures that we do not reach the solver iteration limit and fail with a +more meaningful error message (see T19627) + +This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field. +-} + + +solveNestedImplications :: Bag Implication + -> TcS (Bag Implication) +-- Precondition: the TcS inerts may contain unsolved simples which have +-- to be converted to givens before we go inside a nested implication. +solveNestedImplications implics + | isEmptyBag implics + = return (emptyBag) + | otherwise + = do { traceTcS "solveNestedImplications starting {" empty + ; unsolved_implics <- mapBagM solveImplication implics + + -- ... and we are back in the original TcS inerts + -- Notice that the original includes the _insoluble_simples so it was safe to ignore + -- them in the beginning of this function. + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ] + + ; return (catBagMaybes unsolved_implics) } + +solveImplication :: Implication -- Wanted + -> TcS (Maybe Implication) -- Simplified implication (empty or singleton) +-- Precondition: The TcS monad contains an empty worklist and given-only inerts +-- which after trying to solve this implication we must restore to their original value +solveImplication imp@(Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_given = given_ids + , ic_wanted = wanteds + , ic_info = info + , ic_status = status }) + | isSolvedStatus status + = return (Just imp) -- Do nothing + + | otherwise -- Even for IC_Insoluble it is worth doing more work + -- The insoluble stuff might be in one sub-implication + -- and other unsolved goals in another; and we want to + -- solve the latter as much as possible + = do { inerts <- getInertSet + ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) + + -- commented out; see `where` clause below + -- ; when debugIsOn check_tc_level + + -- Solve the nested constraints + ; (has_given_eqs, given_insols, residual_wanted) + <- nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info (ic_env imp) + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + + ; residual_wanted <- solveWanteds wanteds + + ; (has_eqs, given_insols) <- getHasGivenEqs tclvl + -- Call getHasGivenEqs /after/ solveWanteds, because + -- solveWanteds can augment the givens, via expandSuperClasses, + -- to reveal given superclass equalities + + ; return (has_eqs, given_insols, residual_wanted) } + + ; traceTcS "solveImplication 2" + (ppr given_insols $$ ppr residual_wanted) + ; let final_wanted = residual_wanted `addInsols` given_insols + -- Don't lose track of the insoluble givens, + -- which signal unreachable code; put them in ic_wanted + + ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs + , ic_wanted = final_wanted }) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; traceTcS "solveImplication end }" $ vcat + [ text "has_given_eqs =" <+> ppr has_given_eqs + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) + , text "implication tvcs =" <+> ppr tcvs ] + + ; return res_implic } + + -- TcLevels must be strictly increasing (see (ImplicInv) in + -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType), + -- and in fact I think they should always increase one level at a time. + + -- Though sensible, this check causes lots of testsuite failures. It is + -- remaining commented out for now. + {- + check_tc_level = do { cur_lvl <- TcS.getTcLevel + ; massertPpr (tclvl == pushTcLevel cur_lvl) + (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) } + -} + +---------------------- +setImplicationStatus :: Implication -> TcS (Maybe Implication) +-- Finalise the implication returned from solveImplication, +-- setting the ic_status field +-- Precondition: the ic_status field is not already IC_Solved +-- Return Nothing if we can discard the implication altogether +setImplicationStatus implic@(Implic { ic_status = status + , ic_info = info + , ic_wanted = wc + , ic_given = givens }) + | assertPpr (not (isSolvedStatus status)) (ppr info) $ + -- Precondition: we only set the status if it is not already solved + not (isSolvedWC pruned_wc) + = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) + + ; implic <- neededEvVars implic + + ; let new_status | insolubleWC pruned_wc = IC_Insoluble + | otherwise = IC_Unsolved + new_implic = implic { ic_status = new_status + , ic_wanted = pruned_wc } + + ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) + + ; return $ Just new_implic } + + | otherwise -- Everything is solved + -- Set status to IC_Solved, + -- and compute the dead givens and outer needs + -- See Note [Tracking redundant constraints] + = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) + + ; implic@(Implic { ic_need_inner = need_inner + , ic_need_outer = need_outer }) <- neededEvVars implic + + ; bad_telescope <- checkBadTelescope implic + + ; let warn_givens = findUnnecessaryGivens info need_inner givens + + discard_entire_implication -- Can we discard the entire implication? + = null warn_givens -- No warning from this implication + && not bad_telescope + && isEmptyWC pruned_wc -- No live children + && isEmptyVarSet need_outer -- No needed vars to pass up to parent + + final_status + | bad_telescope = IC_BadTelescope + | otherwise = IC_Solved { ics_dead = warn_givens } + final_implic = implic { ic_status = final_status + , ic_wanted = pruned_wc } + + ; traceTcS "setImplicationStatus(all-solved) }" $ + vcat [ text "discard:" <+> ppr discard_entire_implication + , text "new_implic:" <+> ppr final_implic ] + + ; return $ if discard_entire_implication + then Nothing + else Just final_implic } + where + WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc + + pruned_implics = filterBag keep_me implics + pruned_wc = WC { wc_simple = simples + , wc_impl = pruned_implics + , wc_errors = errs } -- do not prune holes; these should be reported + + keep_me :: Implication -> Bool + keep_me ic + | IC_Solved { ics_dead = dead_givens } <- ic_status ic + -- Fully solved + , null dead_givens -- No redundant givens to report + , isEmptyBag (wc_impl (ic_wanted ic)) + -- And no children that might have things to report + = False -- Tnen we don't need to keep it + | otherwise + = True -- Otherwise, keep it + +findUnnecessaryGivens :: SkolemInfoAnon -> VarSet -> [EvVar] -> [EvVar] +findUnnecessaryGivens info need_inner givens + | not (warnRedundantGivens info) -- Don't report redundant constraints at all + = [] + + | not (null unused_givens) -- Some givens are literally unused + = unused_givens + + | otherwise -- All givens are used, but some might + = redundant_givens -- still be redundant e.g. (Eq a, Ord a) + + where + in_instance_decl = case info of { InstSkol {} -> True; _ -> False } + -- See Note [Redundant constraints in instance decls] + + unused_givens = filterOut is_used givens + + is_used given = is_type_error given + || given `elemVarSet` need_inner + || (in_instance_decl && is_improving (idType given)) + + minimal_givens = mkMinimalBySCs evVarPred givens + is_minimal = (`elemVarSet` mkVarSet minimal_givens) + redundant_givens + | in_instance_decl = [] + | otherwise = filterOut is_minimal givens + + -- See #15232 + is_type_error id = isTopLevelUserTypeError (idType id) + + is_improving pred -- (transSuperClasses p) does not include p + = any isImprovementPred (pred : transSuperClasses pred) + +{- Note [Redundant constraints in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instance declarations are special in two ways: + +* We don't report unused givens if they can give rise to improvement. + Example (#10100): + class Add a b ab | a b -> ab, a ab -> b + instance Add Zero b b + instance Add a b ab => Add (Succ a) b (Succ ab) + The context (Add a b ab) for the instance is clearly unused in terms + of evidence, since the dictionary has no fields. But it is still + needed! With the context, a wanted constraint + Add (Succ Zero) beta (Succ Zero) + we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. + But without the context we won't find beta := Zero. + + This only matters in instance declarations. + +* We don't report givens that are a superclass of another given. E.g. + class Ord r => UserOfRegs r a where ... + instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + The (Ord r) is not redundant, even though it is a superclass of + (UserOfRegs r CmmReg). See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. + + Again this is specific to instance declarations. +-} + + +checkBadTelescope :: Implication -> TcS Bool +-- True <=> the skolems form a bad telescope +-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint +checkBadTelescope (Implic { ic_info = info + , ic_skols = skols }) + | checkTelescopeSkol info + = do{ skols <- mapM TcS.zonkTyCoVarKind skols + ; return (go emptyVarSet (reverse skols))} + + | otherwise + = return False + + where + go :: TyVarSet -- skolems that appear *later* than the current ones + -> [TcTyVar] -- ordered skolems, in reverse order + -> Bool -- True <=> there is an out-of-order skolem + go _ [] = False + go later_skols (one_skol : earlier_skols) + | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols + = True + | otherwise + = go (later_skols `extendVarSet` one_skol) earlier_skols + +warnRedundantGivens :: SkolemInfoAnon -> Bool +warnRedundantGivens (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt _ rrc -> reportRedundantConstraints rrc + ExprSigCtxt rrc -> reportRedundantConstraints rrc + _ -> False + + -- To think about: do we want to report redundant givens for + -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. +warnRedundantGivens (InstSkol {}) = True +warnRedundantGivens _ = False + +neededEvVars :: Implication -> TcS Implication +-- Find all the evidence variables that are "needed", +-- and delete dead evidence bindings +-- See Note [Tracking redundant constraints] +-- See Note [Delete dead Given evidence bindings] +-- +-- - Start from initial_seeds (from nested implications) +-- +-- - Add free vars of RHS of all Wanted evidence bindings +-- and coercion variables accumulated in tcvs (all Wanted) +-- +-- - Generate 'needed', the needed set of EvVars, by doing transitive +-- closure through Given bindings +-- e.g. Needed {a,b} +-- Given a = sc_sel a2 +-- Then a2 is needed too +-- +-- - Prune out all Given bindings that are not needed +-- +-- - From the 'needed' set, delete ev_bndrs, the binders of the +-- evidence bindings, to give the final needed variables +-- +neededEvVars implic@(Implic { ic_given = givens + , ic_binds = ev_binds_var + , ic_wanted = WC { wc_impl = implics } + , ic_need_inner = old_needs }) + = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + + ; let seeds1 = foldr add_implic_seeds old_needs implics + 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 = varSetMinusEvBindMap need_inner live_ev_binds + `delVarSetList` givens + + ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds + -- See Note [Delete dead Given evidence bindings] + + ; traceTcS "neededEvVars" $ + vcat [ text "old_needs:" <+> ppr old_needs + , text "seeds3:" <+> ppr seeds3 + , text "tcvs:" <+> ppr tcvs + , text "ev_binds:" <+> ppr ev_binds + , text "live_ev_binds:" <+> ppr live_ev_binds ] + + ; return (implic { ic_need_inner = need_inner + , ic_need_outer = need_outer }) } + where + add_implic_seeds (Implic { ic_need_outer = needs }) acc + = needs `unionVarSet` acc + + needed_ev_bind needed (EvBind { eb_lhs = ev_var + , eb_info = info }) + | EvBindGiven{} <- info = ev_var `elemVarSet` needed + | otherwise = True -- Keep all wanted bindings + + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs + | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = evVarsOfTerm rhs `unionVarSet` needs + +------------------------------------------------- +simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError) +-- Simplify any delayed errors: e.g. type and term holes +-- NB: At this point we have finished with all the simple +-- constraints; they are in wc_simple, not in the inert set. +-- So those Wanteds will not rewrite these delayed errors. +-- That's probably no bad thing. +-- +-- However if we have [W] alpha ~ Maybe a, [W] alpha ~ Int +-- and _ : alpha, then we'll /unify/ alpha with the first of +-- the Wanteds we get, and thereby report (_ : Maybe a) or +-- (_ : Int) unpredictably, depending on which we happen to see +-- first. Doesn't matter much; there is a type error anyhow. +-- T17139 is a case in point. +simplifyDelayedErrors = mapBagM simpl_err + where + simpl_err :: DelayedError -> TcS DelayedError + simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole + simpl_err err@(DE_NotConcrete {}) = return err + + simpl_hole :: Hole -> TcS Hole + + -- See Note [Do not simplify ConstraintHoles] + simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h + + -- other wildcards should be simplified for printing + -- we must do so here, and not in the error-message generation + -- code, because we have all the givens already set up + simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) + = do { ty' <- rewriteType loc ty + ; traceTcS "simpl_hole" (ppr ty $$ ppr ty') + ; return (h { hole_ty = ty' }) } + +{- Note [Delete dead Given evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a result of superclass expansion, we speculatively +generate evidence bindings for Givens. E.g. + f :: (a ~ b) => a -> b -> Bool + f x y = ... +We'll have + [G] d1 :: (a~b) +and we'll speculatively generate the evidence binding + [G] d2 :: (a ~# b) = sc_sel d + +Now d2 is available for solving. But it may not be needed! Usually +such dead superclass selections will eventually be dropped as dead +code, but: + + * It won't always be dropped (#13032). In the case of an + unlifted-equality superclass like d2 above, we generate + case heq_sc d1 of d2 -> ... + and we can't (in general) drop that case expression in case + d1 is bottom. So it's technically unsound to have added it + in the first place. + + * Simply generating all those extra superclasses can generate lots of + code that has to be zonked, only to be discarded later. Better not + to generate it in the first place. + + Moreover, if we simplify this implication more than once + (e.g. because we can't solve it completely on the first iteration + of simpl_loop), we'll generate all the same bindings AGAIN! + +Easy solution: take advantage of the work we are doing to track dead +(unused) Givens, and use it to prune the Given bindings too. This is +all done by neededEvVars. + +This led to a remarkable 25% overall compiler allocation decrease in +test T12227. + +But we don't get to discard all redundant equality superclasses, alas; +see #15205. + +Note [Do not simplify ConstraintHoles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before printing the inferred value for a type hole (a _ wildcard in +a partial type signature), we simplify it w.r.t. any Givens. This +makes for an easier-to-understand diagnostic for the user. + +However, we do not wish to do this for extra-constraint holes. Here is +the example for why (partial-sigs/should_compile/T12844): + + bar :: _ => FooData rngs + bar = foo + + data FooData rngs + + class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs + + type family Head (xs :: [k]) where Head (x ': xs) = x + +GHC correctly infers that the extra-constraints wildcard on `bar` +should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this +constraint as a Given on the implication constraint for `bar`. (This +implication is emitted by emitResidualConstraints.) The Hole for the _ +is stored within the implication's WantedConstraints. When +simplifyHoles is called, that constraint is already assumed as a +Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r, +r'), Foo rngs), which is disastrous. + +Furthermore, there is no need to simplify here: extra-constraints wildcards +are filled in with the output of the solver, in chooseInferredQuantifiers +(choose_psig_context), so they are already simplified. (Contrast to normal +type holes, which are just bound to a meta-variable.) Avoiding the poor output +is simple: just don't simplify extra-constraints wildcards. + +This is the only reason we need to track ConstraintHole separately +from TypeHole in HoleSort. + +See also Note [Extra-constraint holes in partial type signatures] +in GHC.Tc.Gen.HsType. + +Note [Tracking redundant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Opt_WarnRedundantConstraints, GHC can report which +constraints of a type signature (or instance declaration) are +redundant, and can be omitted. Here is an overview of how it +works. + +This is all tested in typecheck/should_compile/T20602 (among +others). + +----- What is a redundant constraint? + +* The things that can be redundant are precisely the Given + constraints of an implication. + +* A constraint can be redundant in two different ways: + a) It is not needed by the Wanted constraints covered by the + implication E.g. + f :: Eq a => a -> Bool + f x = True -- Equality not used + b) It is implied by other givens. E.g. + f :: (Eq a, Ord a) => blah -- Eq a unnecessary + g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary + +* To find (a) we need to know which evidence bindings are 'wanted'; + hence the eb_is_given field on an EvBind. + +* To find (b), we use mkMinimalBySCs on the Givens to see if any + are unnecessary. + +----- How tracking works + +(RC1) When two Givens are the same, we drop the evidence for the one + that requires more superclass selectors. This is done + according to 2(c) of Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. + +(RC2) The ic_need fields of an Implic records in-scope (given) evidence + variables bound by the context, that were needed to solve this + implication (so far). See the declaration of Implication. + +(RC3) setImplicationStatus: + When the constraint solver finishes solving all the wanteds in + an implication, it sets its status to IC_Solved + + - The ics_dead field, of IC_Solved, records the subset of this + implication's ic_given that are redundant (not needed). + + - We compute which evidence variables are needed by an implication + in setImplicationStatus. A variable is needed if + a) it is free in the RHS of a Wanted EvBind, + b) it is free in the RHS of an EvBind whose LHS is needed, or + c) it is in the ics_need of a nested implication. + + - After computing which variables are needed, we then look at the + remaining variables for internal redundancies. This is case (b) + from above. This is also done in setImplicationStatus. + Note that we only look for case (b) if case (a) shows up empty, + as exemplified below. + + - We need to be careful not to discard an implication + prematurely, even one that is fully solved, because we might + thereby forget which variables it needs, and hence wrongly + report a constraint as redundant. But we can discard it once + its free vars have been incorporated into its parent; or if it + simply has no free vars. This careful discarding is also + handled in setImplicationStatus. + +(RC4) We do not want to report redundant constraints for implications + that come from quantified constraints. Example #23323: + data T a + instance Show (T a) where ... -- No context! + foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int + bar = foo @T @Eq + + The call to `foo` gives us + [W] d : (forall a. Eq a => Show (T a)) + To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: + forall a. Eq a => [W] ds : Show (T a) + and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` + constraint. But we don't want to report it as redundant! + +* Examples: + + f, g, h :: (Eq a, Ord a) => a -> Bool + f x = x == x + g x = x > x + h x = x == x && x > x + + All three will discover that they have two [G] Eq a constraints: + one as given and one extracted from the Ord a constraint. They will + both discard the latter, as noted above and in + Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. + + The body of f uses the [G] Eq a, but not the [G] Ord a. It will + report a redundant Ord a using the logic for case (a). + + The body of g uses the [G] Ord a, but not the [G] Eq a. It will + report a redundant Eq a using the logic for case (a). + + The body of h uses both [G] Ord a and [G] Eq a. Case (a) will + thus come up with nothing redundant. But then, the case (b) + check will discover that Eq a is redundant and report this. + + If we did case (b) even when case (a) reports something, then + we would report both constraints as redundant for f, which is + terrible. + +----- Reporting redundant constraints + +* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints. + +* We don't report redundant givens for *every* implication; only + for those which reply True to GHC.Tc.Solver.warnRedundantGivens: + + - For example, in a class declaration, the default method *can* + use the class constraint, but it certainly doesn't *have* to, + and we don't want to report an error there. Ditto instance decls. + + - More subtly, in a function definition + f :: (Ord a, Ord a, Ix a) => a -> a + f x = rhs + we do an ambiguity check on the type (which would find that one + of the Ord a constraints was redundant), and then we check that + the definition has that type (which might find that both are + redundant). We don't want to report the same error twice, so we + disable it for the ambiguity check. Hence using two different + FunSigCtxts, one with the warn-redundant field set True, and the + other set False in + - GHC.Tc.Gen.Bind.tcSpecPrag + - GHC.Tc.Gen.Bind.tcTySig + + This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors + so that we can discard implication constraints that we don't need. + So ics_dead consists only of the *reportable* redundant givens. + +----- Shortcomings + +Shortcoming 1. Consider + + j :: (Eq a, a ~ b) => a -> Bool + j x = x == x + + k :: (Eq a, b ~ a) => a -> Bool + k x = x == x + +Currently (Nov 2021), j issues no warning, while k says that b ~ a +is redundant. This is because j uses the a ~ b constraint to rewrite +everything to be in terms of b, while k does none of that. This is +ridiculous, but I (Richard E) don't see a good fix. + +Shortcoming 2. Removing a redundant constraint can cause clients to fail to +compile, by making the function more polymoprhic. Consider (#16154) + + f :: (a ~ Bool) => a -> Int + f x = 3 + + g :: String -> Int + g s = f (read s) + +The constraint in f's signature is redundant; not used to typecheck +`f`. And yet if you remove it, `g` won't compile, because there'll +be an ambiguous variable in `g`. +-} + +-- | Like 'defaultTyVar', but in the TcS monad. +defaultTyVarTcS :: TcTyVar -> TcS Bool +defaultTyVarTcS the_tv + | isTyVarTyVar the_tv + -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar + -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return False + | isRuntimeRepVar the_tv + = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) + ; unifyTyVar the_tv liftedRepTy + ; return True } + | isLevityVar the_tv + = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv) + ; unifyTyVar the_tv liftedDataConTy + ; return True } + | isMultiplicityVar the_tv + = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) + ; unifyTyVar the_tv ManyTy + ; return True } + | otherwise + = return False -- the common case + +approximateWC :: Bool -- See Wrinkle (W3) in Note [ApproximateWC] + -> WantedConstraints + -> Cts +-- Second return value is the depleted wc +-- Postcondition: Wanted Cts +-- See Note [ApproximateWC] +-- See Note [floatKindEqualities vs approximateWC] +approximateWC float_past_equalities wc + = float_wc False emptyVarSet wc + where + float_wc :: Bool -- True <=> there are enclosing equalities + -> TcTyCoVarSet -- Enclosing skolem binders + -> WantedConstraints -> Cts + float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) + = filterBag (is_floatable encl_eqs trapping_tvs) simples `unionBags` + concatMapBag (float_implic encl_eqs trapping_tvs) implics + + float_implic :: Bool -> TcTyCoVarSet -> Implication -> Cts + float_implic encl_eqs trapping_tvs imp + = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp) + where + new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp + new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs + + is_floatable encl_eqs skol_tvs ct + | isGivenCt ct = False + | insolubleCt ct = False + | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = False + | otherwise + = case classifyPredType (ctPred ct) of + EqPred {} -> float_past_equalities || not encl_eqs + -- See Wrinkle (W1) + ClassPred {} -> True -- See Wrinkle (W2) + IrredPred {} -> True -- ..both in Note [ApproximateWC] + ForAllPred {} -> False + +{- Note [ApproximateWC] +~~~~~~~~~~~~~~~~~~~~~~~ +approximateWC takes a constraint, typically arising from the RHS of a +let-binding whose type we are *inferring*, and extracts from it some +*simple* constraints that we might plausibly abstract over. Of course +the top-level simple constraints are plausible, but we also float constraints +out from inside, if they are not captured by skolems. + +The same function is used when doing type-class defaulting (see the call +to applyDefaultingRules) to extract constraints that might be defaulted. + +Wrinkle (W1) + When inferring most-general types (in simplifyInfer), we + do *not* float an equality constraint if the implication binds + equality constraints, because that defeats the OutsideIn story. + Consider data T a where TInt :: T Int MkT :: T a + + f TInt = 3::Int + + We get the implication (a ~ Int => res ~ Int), where so far we've decided + f :: T a -> res + We don't want to float (res~Int) out because then we'll infer + f :: T a -> Int + which is only on of the possible types. (GHC 7.6 accidentally *did* + float out of such implications, which meant it would happily infer + non-principal types.) + +Wrinkle (W2) + We do allow /class/ constraints to float, even if + the implication binds equalities. This is a subtle point: see #23224. + In principle, a class constraint might ultimately be satisfiable from + a constraint bound by an implication (see #19106 for an example of this + kind), but it's extremely obscure and I was unable to construct a + concrete example. In any case, in super-subtle cases where this might + make a difference, you would be much better advised to simply write a + type signature. + + I included IrredPred here too, for good measure. In general, + abstracting over more constraints does no harm. + +Wrinkle (W3) + In findDefaultableGroups we are not worried about the + most-general type; and we /do/ want to float out of equalities + (#12797). Hence the boolean flag to approximateWC. + +------ Historical note ----------- +There used to be a second caveat, driven by #8155 + + 2. We do not float out an inner constraint that shares a type variable + (transitively) with one that is trapped by a skolem. Eg + forall a. F a ~ beta, Integral beta + We don't want to float out (Integral beta). Doing so would be bad + when defaulting, because then we'll default beta:=Integer, and that + makes the error message much worse; we'd get + Can't solve F a ~ Integer + rather than + Can't solve Integral (F a) + + Moreover, floating out these "contaminated" constraints doesn't help + when generalising either. If we generalise over (Integral b), we still + can't solve the retained implication (forall a. F a ~ b). Indeed, + arguably that too would be a harder error to understand. + +But this transitive closure stuff gives rise to a complex rule for +when defaulting actually happens, and one that was never documented. +Moreover (#12923), the more complex rule is sometimes NOT what +you want. So I simply removed the extra code to implement the +contamination stuff. There was zero effect on the testsuite (not even #8155). +------ End of historical note ----------- + +Note [DefaultTyVar] +~~~~~~~~~~~~~~~~~~~ +defaultTyVar is used on any un-instantiated meta type variables to +default any RuntimeRep variables to LiftedRep. This is important +to ensure that instance declarations match. For example consider + + instance Show (a->b) + foo x = show (\_ -> True) + +Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), +and that won't match the typeKind (*) in the instance decl. See tests +tc217 and tc175. + +We look only at touchable type variables. No further constraints +are going to affect these type variables, so it's time to do it by +hand. However we aren't ready to default them fully to () or +whatever, because the type-class defaulting rules have yet to run. + +An alternate implementation would be to emit a Wanted constraint setting +the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. + +Note [Promote _and_ default when inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are inferring a type, we simplify the constraint, and then use +approximateWC to produce a list of candidate constraints. Then we MUST + + a) Promote any meta-tyvars that have been floated out by + approximateWC, to restore invariant (WantedInv) described in + Note [TcLevel invariants] in GHC.Tc.Utils.TcType. + + b) Default the kind of any meta-tyvars that are not mentioned in + in the environment. + +To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we +have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it +should! If we don't solve the constraint, we'll stupidly quantify over +(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over +(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. +#7641 is a simpler example. + +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(WantedInv) from Note [TcLevel invariants] in GHC.Tc.Types.TcType. + +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] + +We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. +They may react to yield that (beta := [alpha]) which can then be pushed inwards +the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that +(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable +beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: + + class C x y | x -> y where + op :: x -> y -> () + + instance C [a] [a] + + type family F a :: * + + h :: F Int -> () + h = undefined + + data TEx where + TEx :: a -> TEx + + f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) + + +********************************************************************************* +* * +* Defaulting and disambiguation * +* * +********************************************************************************* + +Note [Defaulting plugins] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Defaulting plugins enable extending or overriding the defaulting +behaviour. In `applyDefaulting`, before the built-in defaulting +mechanism runs, the loaded defaulting plugins are passed the +`WantedConstraints` and get a chance to propose defaulting assignments +based on them. + +Proposals are represented as `[DefaultingProposal]` with each proposal +consisting of a type variable to fill-in, the list of defaulting types to +try in order, and a set of constraints to check at each try. This is +the same representation (albeit in a nicely packaged-up data type) as +the candidates generated by the built-in defaulting mechanism, so the +actual trying of proposals is done by the same `disambigGroup` function. + +Wrinkle (DP1): The role of `WantedConstraints` + + Plugins are passed `WantedConstraints` that can perhaps be + progressed on by defaulting. But a defaulting plugin is not a solver + plugin, its job is to provide defaulting proposals, i.e. mappings of + type variable to types. How do plugins know which type variables + they are supposed to default? + + The `WantedConstraints` passed to the defaulting plugin are zonked + beforehand to ensure all remaining metavariables are unfilled. Thus, + the `WantedConstraints` serve a dual purpose: they are both the + constraints of the given context that can act as hints to the + defaulting, as well as the containers of the type variables under + consideration for defaulting. + +Wrinkle (DP2): Interactions between defaulting mechanisms + + In the general case, we have multiple defaulting plugins loaded and + there is also the built-in defaulting mechanism. In this case, we + have to be careful to keep the `WantedConstraints` passed to the + plugins up-to-date by zonking between successful defaulting + rounds. Otherwise, two plugins might come up with a defaulting + proposal for the same metavariable; if the first one is accepted by + `disambigGroup` (thus the meta gets filled), the second proposal + becomes invalid (see #23821 for an example). + +-} + +applyDefaultingRules :: WantedConstraints -> TcS Bool +-- True <=> I did some defaulting, by unifying a meta-tyvar +-- Input WantedConstraints are not necessarily zonked + +applyDefaultingRules wanteds + | isEmptyWC wanteds + = return False + | otherwise + = do { info@(default_tys, _) <- getDefaultInfo + ; wanteds <- TcS.zonkWC wanteds + + ; tcg_env <- TcS.getGblEnv + ; let plugins = tcg_defaulting_plugins tcg_env + + -- Run any defaulting plugins + -- See Note [Defaulting plugins] for an overview + ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else + do { + ; traceTcS "defaultingPlugins {" (ppr wanteds) + ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins + ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) + ; return (wanteds, defaultedGroups) + } + + ; let groups = findDefaultableGroups info wanteds + + ; traceTcS "applyDefaultingRules {" $ + vcat [ text "wanteds =" <+> ppr wanteds + , text "groups =" <+> ppr groups + , text "info =" <+> ppr info ] + + ; something_happeneds <- mapM (disambigGroup default_tys) groups + + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) + + ; return $ or something_happeneds || or plugin_defaulted } + where run_defaulting_plugin wanteds p = + do { groups <- runTcPluginTcS (p wanteds) + ; defaultedGroups <- + filterM (\g -> disambigGroup + (deProposalCandidates g) + (deProposalTyVar g, deProposalCts g)) + groups + ; traceTcS "defaultingPlugin " $ ppr defaultedGroups + ; case defaultedGroups of + [] -> return (wanteds, False) + _ -> do + -- If a defaulting plugin solves any tyvars, some of the wanteds + -- will have filled-in metavars by now (see wrinkle DP2 of + -- Note [Defaulting plugins]). So we re-zonk to make sure later + -- defaulting doesn't try to solve the same metavars. + wanteds' <- TcS.zonkWC wanteds + return (wanteds', True) + } + + +findDefaultableGroups + :: ( [Type] + , (Bool,Bool) ) -- (Overloaded strings, extended default rules) + -> WantedConstraints -- Unsolved + -> [(TyVar, [Ct])] +findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds + | null default_tys + = [] + | otherwise + = [ (tv, map fstOf3 group) + | group'@((_,_,tv) :| _) <- unary_groups + , let group = toList group' + , defaultable_tyvar tv + , defaultable_classes (map sndOf3 group) ] + where + simples = approximateWC True wanteds + (unaries, non_unaries) = partitionWith find_unary (bagToList simples) + unary_groups = equivClasses cmp_tv unaries + + unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints + non_unaries :: [Ct] -- and *other* constraints + + -- Finds unary type-class constraints + -- But take account of polykinded classes like Typeable, + -- which may look like (Typeable * (a:*)) (#8931) + find_unary :: Ct -> Either (Ct, Class, TyVar) Ct + find_unary cc + | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) + , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys + -- Ignore invisible arguments for this purpose + , Just tv <- getTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) + find_unary cc = Right cc -- Non unary or non dictionary + + bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries + bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries + + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 + + defaultable_tyvar :: TcTyVar -> Bool + defaultable_tyvar tv + = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] + b2 = not (tv `elemVarSet` bad_tvs) + in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] + + defaultable_classes :: [Class] -> Bool + defaultable_classes clss + | extended_defaults = any (isInteractiveClass ovl_strings) clss + | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) + + -- is_std_class adds IsString to the standard numeric classes, + -- when -XOverloadedStrings is enabled + is_std_class cls = isStandardClass cls || + (ovl_strings && (cls `hasKey` isStringClassKey)) + +------------------------------ +disambigGroup :: [Type] -- The default types + -> (TcTyVar, [Ct]) -- All constraints sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds + +disambigGroup [] _ + = return False +disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) + = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) + ; fake_ev_binds_var <- TcS.newTcEvBinds + ; tclvl <- TcS.getTcLevel + ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group + + ; if success then + -- Success: record the type variable binding, and return + do { unifyTyVar the_tv default_ty + ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty + ; traceTcS "disambigGroup succeeded }" (ppr default_ty) + ; return True } + else + -- Failure: try with the next type + do { traceTcS "disambigGroup failed, will try other default types }" + (ppr default_ty) + ; disambigGroup default_tys group } } + where + try_group + | Just subst <- mb_subst + = do { lcl_env <- TcS.getLclEnv + ; tc_lvl <- TcS.getTcLevel + ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) -- Equality constraints are possible due to type defaulting plugins ; wanted_evs <- sequence [ newWantedNC loc rewriters pred' | wanted <- wanteds diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs deleted file mode 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ /dev/null @@ -1,3421 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecursiveDo #-} - -module GHC.Tc.Solver.Canonical( - canonicalize, - unifyWanted, - makeSuperClasses, - StopOrContinue(..), stopWith, continueWith, andWhenContinue, - rewriteEqEvidence, - solveCallStack -- For GHC.Tc.Solver - ) where - -import GHC.Prelude - -import GHC.Tc.Types.Constraint -import GHC.Core.Predicate -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Unify -import GHC.Tc.Utils.TcType -import GHC.Core.Type -import GHC.Tc.Solver.Rewrite -import GHC.Tc.Solver.Monad -import GHC.Tc.Solver.InertSet -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.EvTerm -import GHC.Core.Class -import GHC.Core.DataCon ( dataConName ) -import GHC.Core.TyCon -import GHC.Core.Multiplicity -import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking -import GHC.Core.Coercion -import GHC.Core.Coercion.Axiom -import GHC.Core.Reduction -import GHC.Core -import GHC.Types.Id( mkTemplateLocals ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) -import GHC.Types.Var -import GHC.Types.Var.Env( mkInScopeSet ) -import GHC.Types.Var.Set( delVarSetList, anyVarSet ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Builtin.Types ( anyTypeOfKind ) -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Hs.Type( HsIPName(..) ) -import GHC.Types.Unique ( hasKey ) -import GHC.Builtin.Names ( coercibleTyConKey ) - -import GHC.Data.Pair -import GHC.Utils.Misc -import GHC.Data.Bag -import GHC.Utils.Monad -import GHC.Utils.Constants( debugIsOn ) -import Control.Monad -import Data.Maybe ( isJust, isNothing ) -import Data.List ( zip4 ) -import GHC.Types.Basic - -import qualified Data.Semigroup as S -import Data.Bifunctor ( bimap ) - -{- -************************************************************************ -* * -* The Canonicaliser * -* * -************************************************************************ - -Note [Canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~ - -Canonicalization converts a simple constraint to a canonical form. It is -unary (i.e. treats individual constraints one at a time). - -Constraints originating from user-written code come into being as -CNonCanonicals. We know nothing about these constraints. So, first: - - Classify CNonCanoncal constraints, depending on whether they - are equalities, class predicates, or other. - -Then proceed depending on the shape of the constraint. Generally speaking, -each constraint gets rewritten and then decomposed into one of several forms -(see type Ct in GHC.Tc.Types). - -When an already-canonicalized constraint gets kicked out of the inert set, -it must be recanonicalized. But we know a bit about its shape from the -last time through, so we can skip the classification step. - --} - --- Top-level canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -canonicalize :: Ct -> TcS (StopOrContinue Ct) -canonicalize (CNonCanonical { cc_ev = ev }) - = {-# SCC "canNC" #-} - canNC ev - -canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = canForAll ev pend_sc - -canonicalize (CIrredCan { cc_ev = ev }) - = canNC ev - -- Instead of rewriting the evidence before classifying, it's possible we - -- can make progress without the rewrite. Try this first. - -- For insolubles (all of which are equalities), do /not/ rewrite the arguments - -- In #14350 doing so led entire-unnecessary and ridiculously large - -- type function expansion. Instead, canEqNC just applies - -- the substitution to the predicate, and may do decomposition; - -- e.g. a ~ [a], where [G] a ~ [Int], can decompose - -canonicalize (CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis, cc_pend_sc = pend_sc }) - = {-# SCC "canClass" #-} - canClass ev cls xis pend_sc - -canonicalize (CEqCan { cc_ev = ev - , cc_lhs = lhs - , cc_rhs = rhs - , cc_eq_rel = eq_rel }) - = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (canEqLHSType lhs) rhs - -canNC :: CtEvidence -> TcS (StopOrContinue Ct) -canNC ev = - case classifyPredType pred of - ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) - canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) - canEqNC ev eq_rel ty1 ty2 - IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) - canIrred ev - ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs th p - - where - pred = ctEvPred ev - -{- -************************************************************************ -* * -* Class Canonicalization -* * -************************************************************************ --} - -canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) --- "NC" means "non-canonical"; that is, we have got here --- from a NonCanonical constraint, not from a CDictCan --- Precondition: EvVar is class evidence -canClassNC ev cls tys - | isGiven ev -- See Note [Eagerly expand given superclasses] - = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys - ; emitWork sc_cts - ; canClass ev cls tys False } - - | CtWanted { ctev_rewriters = rewriters } <- ev - , Just ip_name <- isCallStackPred cls tys - , isPushCallStackOrigin orig - -- If we're given a CallStack constraint that arose from a function - -- call, we need to push the current call-site onto the stack instead - -- of solving it directly from a given. - -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types - = do { -- First we emit a new constraint that will capture the - -- given CallStack. - ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) - -- We change the origin to IPOccOrigin so - -- this rule does not fire again. - -- See Note [Overview of implicit CallStacks] - -- in GHC.Tc.Types.Evidence - - ; new_ev <- newWantedEvVarNC new_loc rewriters pred - - -- Then we solve the wanted by pushing the call-site - -- onto the newly emitted CallStack - ; let ev_cs = EvCsPushCall (callStackOriginFS orig) - (ctLocSpan loc) (ctEvExpr new_ev) - ; solveCallStack ev ev_cs - - ; canClass new_ev cls tys False -- No superclasses - } - - | otherwise - = canClass ev cls tys (has_scs cls) - - where - has_scs cls = not (null (classSCTheta cls)) - loc = ctEvLoc ev - orig = ctLocOrigin loc - pred = ctEvPred ev - -solveCallStack :: CtEvidence -> EvCallStack -> TcS () --- Also called from GHC.Tc.Solver when defaulting call stacks -solveCallStack ev ev_cs = do - -- We're given ev_cs :: CallStack, but the evidence term should be a - -- dictionary, so we have to coerce ev_cs to a dictionary for - -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] - cs_tm <- evCallStack ev_cs - let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) - setEvBindIfWanted ev ev_tm - -canClass :: CtEvidence - -> Class -> [Type] - -> Bool -- True <=> un-explored superclasses - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc - = -- all classes do *nominal* matching - assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ - do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys - ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns - mk_ct new_ev = CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc } - ; mb <- rewriteEvidence rewriters ev redn - ; traceTcS "canClass" (vcat [ ppr ev - , ppr xi, ppr mb ]) - ; return (fmap mk_ct mb) } - where - cls_tc = classTyCon cls - -{- Note [The superclass story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to add superclass constraints for two reasons: - -* For givens [G], they give us a route to proof. E.g. - f :: Ord a => a -> Bool - f x = x == x - We get a Wanted (Eq a), which can only be solved from the superclass - of the Given (Ord a). - -* For wanteds [W], they may give useful - functional dependencies. E.g. - class C a b | a -> b where ... - class C a b => D a b where ... - Now a [W] constraint (D Int beta) has (C Int beta) as a superclass - and that might tell us about beta, via C's fundeps. We can get this - by generating a [W] (C Int beta) constraint. We won't use the evidence, - but it may lead to unification. - -See Note [Why adding superclasses can help]. - -For these reasons we want to generate superclass constraints for both -Givens and Wanteds. But: - -* (Minor) they are often not needed, so generating them aggressively - is a waste of time. - -* (Major) if we want recursive superclasses, there would be an infinite - number of them. Here is a real-life example (#10318); - - class (Frac (Frac a) ~ Frac a, - Fractional (Frac a), - IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - - Notice that IntegralDomain has an associated type Frac, and one - of IntegralDomain's superclasses is another IntegralDomain constraint. - -So here's the plan: - -1. Eagerly generate superclasses for given (but not wanted) - constraints; see Note [Eagerly expand given superclasses]. - This is done using mkStrictSuperClasses in canClassNC, when - we take a non-canonical Given constraint and cannonicalise it. - - However stop if you encounter the same class twice. That is, - mkStrictSuperClasses expands eagerly, but has a conservative - termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType. - -2. Solve the wanteds as usual, but do no further expansion of - superclasses for canonical CDictCans in solveSimpleGivens or - solveSimpleWanteds; Note [Danger of adding superclasses during solving] - - However, /do/ continue to eagerly expand superclasses for new /given/ - /non-canonical/ constraints (canClassNC does this). As #12175 - showed, a type-family application can expand to a class constraint, - and we want to see its superclasses for just the same reason as - Note [Eagerly expand given superclasses]. - -3. If we have any remaining unsolved wanteds - (see Note [When superclasses help] in GHC.Tc.Types.Constraint) - try harder: take both the Givens and Wanteds, and expand - superclasses again. See the calls to expandSuperClasses in - GHC.Tc.Solver.simpl_loop and solveWanteds. - - This may succeed in generating (a finite number of) extra Givens, - and extra Wanteds. Both may help the proof. - -3a An important wrinkle: only expand Givens from the current level. - Two reasons: - - We only want to expand it once, and that is best done at - the level it is bound, rather than repeatedly at the leaves - of the implication tree - - We may be inside a type where we can't create term-level - evidence anyway, so we can't superclass-expand, say, - (a ~ b) to get (a ~# b). This happened in #15290. - -4. Go round to (2) again. This loop (2,3,4) is implemented - in GHC.Tc.Solver.simpl_loop. - -The cc_pend_sc flag in a CDictCan records whether the superclasses of -this constraint have been expanded. Specifically, in Step 3 we only -expand superclasses for constraints with cc_pend_sc set to true (i.e. -isPendingScDict holds). - -Why do we do this? Two reasons: - -* To avoid repeated work, by repeatedly expanding the superclasses of - same constraint, - -* To terminate the above loop, at least in the -XNoUndecidableSuperClasses - case. If there are recursive superclasses we could, in principle, - expand forever, always encountering new constraints. - -When we take a CNonCanonical or CIrredCan, but end up classifying it -as a CDictCan, we set the cc_pend_sc flag to False. - -Note [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a - class D a => C a - -Then, when we expand superclasses, we'll get back to the self-same -predicate, so we have reached a fixpoint in expansion and there is no -point in fruitlessly expanding further. This case just falls out from -our strategy. Consider - f :: C a => a -> Bool - f x = x==x -Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses -G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its sc_pend flag set.) -When processing d3 we find a match with d1 in the inert set, and we always -keep the inert item (d1) if possible: see Note [Replacement vs keeping] in -GHC.Tc.Solver.Interact. So d3 dies a quick, happy death. - -Note [Eagerly expand given superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step (1) of Note [The superclass story], why do we eagerly expand -Given superclasses by one layer? (By "one layer" we mean expand transitively -until you meet the same class again -- the conservative criterion embodied -in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) -We do this eagerly for Givens mainly because of some very obscure -cases like this: - - instance Bad a => Eq (T a) - - f :: (Ord (T a)) => blah - f x = ....needs Eq (T a), Ord (T a).... - -Here if we can't satisfy (Eq (T a)) from the givens we'll use the -instance declaration; but then we are stuck with (Bad a). Sigh. -This is really a case of non-confluent proofs, but to stop our users -complaining we expand one layer in advance. - -Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. - -We also want to do this if we have - - f :: F (T a) => blah - -where - type instance F (T a) = Ord (T a) - -So we may need to do a little work on the givens to expose the -class that has the superclasses. That's why the superclass -expansion for Givens happens in canClassNC. - -This same scenario happens with quantified constraints, whose superclasses -are also eagerly expanded. Test case: typecheck/should_compile/T16502b -These are handled in canForAllNC, analogously to canClassNC. - -Note [Why adding superclasses can help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Examples of how adding superclasses can help: - - --- Example 1 - class C a b | a -> b - Suppose we want to solve - [G] C a b - [W] C a beta - Then adding [W] beta~b will let us solve it. - - -- Example 2 (similar but using a type-equality superclass) - class (F a ~ b) => C a b - And try to sllve: - [G] C a b - [W] C a beta - Follow the superclass rules to add - [G] F a ~ b - [W] F a ~ beta - Now we get [W] beta ~ b, and can solve that. - - -- Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - - When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hence by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) - Use the instance decl to get - [W] C a beta - Generate its superclass - [W] L a beta. Now using fundeps, combine with [G] L a b to get - [W] beta ~ b - which is what we want. - -Note [Danger of adding superclasses during solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a serious, but now out-dated example, from #4497: - - class Num (RealOf t) => Normed t - type family RealOf x - -Assume the generated wanted constraint is: - [W] RealOf e ~ e - [W] Normed e - -If we were to be adding the superclasses during simplification we'd get: - [W] RealOf e ~ e - [W] Normed e - [W] RealOf e ~ fuv - [W] Num fuv -==> - e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv - -While looks exactly like our original constraint. If we add the -superclass of (Normed fuv) again we'd loop. By adding superclasses -definitely only once, during canonicalisation, this situation can't -happen. - -Note [Nested quantified constraint superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (typecheck/should_compile/T17202) - - class C1 a - class (forall c. C1 c) => C2 a - class (forall b. (b ~ F a) => C2 a) => C3 a - -Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass -to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a -superclass, as well. But we now must be careful: we cannot just add -(forall c. C1 c) as a Given, because we need to remember g2's context. -That new constraint is Given only when forall b. (b ~ F a) is true. - -It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), -but that's problematic, because it's nested, and ForAllPred is not capable -of representing a nested quantified constraint. (We could change ForAllPred -to allow this, but the solution in this Note is much more local and simpler.) - -So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). - -More generally, if we are expanding the superclasses of - g0 :: forall tvs. theta => cls tys -and find a superclass constraint - forall sc_tvs. sc_theta => sc_inner_pred -we must have a selector - sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred -and thus build - g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred - g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids. - sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids - -Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the -last bound variables and the last arguments. This avoids the need to produce -the sc_theta_ids at all. So our final construction is - - g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. - sel_id tys (g0 tvs theta_ids) sc_tvs - - -} - -makeSuperClasses :: [Ct] -> TcS [Ct] --- Returns strict superclasses, transitively, see Note [The superclass story] --- See Note [The superclass story] --- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType --- Specifically, for an incoming (C t) constraint, we return all of (C t)'s --- superclasses, up to /and including/ the first repetition of C --- --- Example: class D a => C a --- class C [a] => D a --- makeSuperClasses (C x) will return (D x, C [x]) --- --- NB: the incoming constraints have had their cc_pend_sc flag already --- flipped to False, by isPendingScDict, so we are /obliged/ to at --- least produce the immediate superclasses -makeSuperClasses cts = concatMapM go cts - where - go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = mkStrictSuperClasses ev [] [] cls tys - go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev })) - = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have - -- class pred heads - mkStrictSuperClasses ev tvs theta cls tys - where - (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) - go ct = pprPanic "makeSuperClasses" (ppr ct) - -mkStrictSuperClasses - :: CtEvidence - -> [TyVar] -> ThetaType -- These two args are non-empty only when taking - -- superclasses of a /quantified/ constraint - -> Class -> [Type] -> TcS [Ct] --- Return constraints for the strict superclasses of --- ev :: forall as. theta => cls tys -mkStrictSuperClasses ev tvs theta cls tys - = mk_strict_superclasses (unitNameSet (className cls)) - ev tvs theta cls tys - -mk_strict_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcS [Ct] --- Always return the immediate superclasses of (cls tys); --- and expand their superclasses, provided none of them are in rec_clss --- nor are repeated -mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) - tvs theta cls tys - = concatMapM do_one_given $ - classSCSelIds cls - where - dict_ids = mkTemplateLocals theta - this_size = pSizeClassPred cls tys - - do_one_given sel_id - | isUnliftedType sc_pred - -- NB: class superclasses are never representation-polymorphic, - -- so isUnliftedType is OK here. - , not (null tvs && null theta) - = -- See Note [Equality superclasses in quantified constraints] - return [] - | otherwise - = do { given_ev <- newGivenEvVar sc_loc $ - mk_given_desc sel_id sc_pred - ; mk_superclasses rec_clss given_ev tvs theta sc_pred } - where - sc_pred = classMethodInstTy sel_id tys - - -- See Note [Nested quantified constraint superclasses] - mk_given_desc :: Id -> PredType -> (PredType, EvTerm) - mk_given_desc sel_id sc_pred - = (swizzled_pred, swizzled_evterm) - where - (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred - (sc_theta, sc_inner_pred) = splitFunTys sc_rho - - all_tvs = tvs `chkAppend` sc_tvs - all_theta = theta `chkAppend` (map scaledThing sc_theta) - swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred - - -- evar :: forall tvs. theta => cls tys - -- sel_id :: forall cls_tvs. cls cls_tvs - -- -> forall sc_tvs. sc_theta => sc_inner_pred - -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred - swizzled_evterm = EvExpr $ - mkLams all_tvs $ - mkLams dict_ids $ - Var sel_id - `mkTyApps` tys - `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) - `mkVarApps` sc_tvs - - sc_loc | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- #10335 - - | isEqPredClass cls || cls `hasKey` coercibleTyConKey - = loc -- The only superclasses of ~, ~~, and Coercible are primitive - -- equalities, and they don't use the GivenSCOrigin mechanism - -- detailed in Note [Solving superclass constraints] in - -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win. - - | otherwise - = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) } - - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in - -- GHC.Tc.Solver.Interact for why we need depths - mk_sc_origin :: CtOrigin -> CtOrigin - mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked) - = GivenSCOrigin skol_info (sc_depth + 1) - (already_blocked || newly_blocked skol_info) - - mk_sc_origin (GivenOrigin skol_info) - = -- These cases do not already have a superclass constraint: depth starts at 1 - GivenSCOrigin skol_info 1 (newly_blocked skol_info) - - mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $ - ppr evar $$ ppr other_orig - - newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size) - newly_blocked _ = False - -mk_strict_superclasses rec_clss ev tvs theta cls tys - | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no superclass constraints. - -- See Note [Improvement from Ground Wanteds] - - | otherwise -- Wanted case, just add Wanted superclasses - -- that can lead to improvement. - = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ - concatMapM do_one (immSuperClasses cls tys) - where - loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) - - do_one sc_pred - = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred) - ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred - ; mk_superclasses rec_clss sc_ev [] [] sc_pred } - -{- Note [Improvement from Ground Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose class C b a => D a b -and consider - [W] D Int Bool -Is there any point in emitting [W] C Bool Int? No! The only point of -emitting superclass constraints for W constraints is to get -improvement, extra unifications that result from functional -dependencies. See Note [Why adding superclasses can help] above. - -But no variables means no improvement; case closed. --} - -mk_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] --- Return this constraint, plus its superclasses, if any -mk_superclasses rec_clss ev tvs theta pred - | ClassPred cls tys <- classifyPredType pred - = mk_superclasses_of rec_clss ev tvs theta cls tys - - | otherwise -- Superclass is not a class predicate - = return [mkNonCanonical ev] - -mk_superclasses_of :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> Class -> [Type] - -> TcS [Ct] --- Always return this class constraint, --- and expand its superclasses -mk_superclasses_of rec_clss ev tvs theta cls tys - | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) - ; return [this_ct] } -- cc_pend_sc of this_ct = True - | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys - , ppr (isCTupleClass cls) - , ppr rec_clss - ]) - ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys - ; return (this_ct : sc_cts) } - -- cc_pend_sc of this_ct = False - where - cls_nm = className cls - loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss - -- Tuples never contribute to recursion, and can be nested - rec_clss' = rec_clss `extendNameSet` cls_nm - - this_ct | null tvs, null theta - = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys - , cc_pend_sc = loop_found } - -- NB: If there is a loop, we cut off, so we have not - -- added the superclasses, hence cc_pend_sc = True - | otherwise - = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys - , qci_ev = ev - , qci_pend_sc = loop_found }) - - -{- Note [Equality superclasses in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15359, #15593, #15625) - f :: (forall a. theta => a ~ b) => stuff - -It's a bit odd to have a local, quantified constraint for `(a~b)`, -but some people want such a thing (see the tickets). And for -Coercible it is definitely useful - f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) - => stuff - -Moreover it's not hard to arrange; we just need to look up /equality/ -constraints in the quantified-constraint environment, which we do in -GHC.Tc.Solver.Interact.doTopReactOther. - -There is a wrinkle though, in the case where 'theta' is empty, so -we have - f :: (forall a. a~b) => stuff - -Now, potentially, the superclass machinery kicks in, in -makeSuperClasses, giving us a a second quantified constraint - (forall a. a ~# b) -BUT this is an unboxed value! And nothing has prepared us for -dictionary "functions" that are unboxed. Actually it does just -about work, but the simplifier ends up with stuff like - case (/\a. eq_sel d) of df -> ...(df @Int)... -and fails to simplify that any further. And it doesn't satisfy -isPredTy any more. - -So for now we simply decline to take superclasses in the quantified -case. Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther, -which looks for primitive equalities specially in the quantified -constraints. - -See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. - - -************************************************************************ -* * -* Irreducibles canonicalization -* * -************************************************************************ --} - -canIrred :: CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred ev - = do { let pred = ctEvPred ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (redn, rewriters) <- rewrite ev pred - ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> - - do { -- Re-classify, in case rewriting has improved its shape - -- Code is like the canNC, except - -- that the IrredPred branch stops work - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so - -- cannot become EqPreds - pprPanic "canIrred: EqPred" - (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2) - ForAllPred tvs th p -> -- this is highly suspect; Quick Look - -- should never leave a meta-var filled - -- in with a polytype. This is #18987. - do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs th p - IrredPred {} -> continueWith $ - mkIrredCt IrredShapeReason new_ev } } - -{- ********************************************************************* -* * -* Quantified predicates -* * -********************************************************************* -} - -{- Note [Quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The -XQuantifiedConstraints extension allows type-class contexts like this: - - data Rose f x = Rose x (f (Rose f x)) - - instance (Eq a, forall b. Eq b => Eq (f b)) - => Eq (Rose f a) where - (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 - -Note the (forall b. Eq b => Eq (f b)) in the instance contexts. -This quantified constraint is needed to solve the - [W] (Eq (f (Rose f x))) -constraint which arises form the (==) definition. - -The wiki page is - https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints -which in turn contains a link to the GHC Proposal where the change -is specified, and a Haskell Symposium paper about it. - -We implement two main extensions to the design in the paper: - - 1. We allow a variable in the instance head, e.g. - f :: forall m a. (forall b. m b) => D (m a) - Notice the 'm' in the head of the quantified constraint, not - a class. - - 2. We support superclasses to quantified constraints. - For example (contrived): - f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool - f x y = x==y - Here we need (Eq (m a)); but the quantified constraint deals only - with Ord. But we can make it work by using its superclass. - -Here are the moving parts - * Language extension {-# LANGUAGE QuantifiedConstraints #-} - and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension - - * A new form of evidence, EvDFun, that is used to discharge - such wanted constraints - - * checkValidType gets some changes to accept forall-constraints - only in the right places. - - * Predicate.Pred gets a new constructor ForAllPred, and - and classifyPredType analyses a PredType to decompose - the new forall-constraints - - * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts, - which holds all the Given forall-constraints. In effect, - such Given constraints are like local instance decls. - - * When trying to solve a class constraint, via - GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts - so that we include the local Given forall-constraints - in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.) - - * GHC.Tc.Solver.Canonical.canForAll deals with solving a - forall-constraint. See - Note [Solving a Wanted forall-constraint] - - * We augment the kick-out code to kick out an inert - forall constraint if it can be rewritten by a new - type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable - -Note that a quantified constraint is never /inferred/ -(by GHC.Tc.Solver.simplifyInfer). A function can only have a -quantified constraint in its type if it is given an explicit -type signature. - --} - -canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Ct) -canForAllNC ev tvs theta pred - | isGiven ev -- See Note [Eagerly expand given superclasses] - , Just (cls, tys) <- cls_pred_tys_maybe - = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys - ; emitWork sc_cts - ; canForAll ev False } - - | otherwise - = canForAll ev (isJust cls_pred_tys_maybe) - - where - cls_pred_tys_maybe = getClassPredTys_maybe pred - -canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) --- We have a constraint (forall as. blah => C tys) -canForAll ev pend_sc - = do { -- First rewrite it to apply the current substitution - let pred = ctEvPred ev - ; (redn, rewriters) <- rewrite ev pred - ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> - - do { -- Now decompose into its pieces and solve it - -- (It takes a lot less code to rewrite before decomposing.) - ; case classifyPredType (ctEvPred new_ev) of - ForAllPred tvs theta pred - -> solveForAll new_ev tvs theta pred pend_sc - _ -> pprPanic "canForAll" (ppr new_ev) - } } - -solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool - -> TcS (StopOrContinue Ct) -solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc }) - tvs theta pred _pend_sc - = -- See Note [Solving a Wanted forall-constraint] - setLclEnv (ctLocEnv loc) $ - -- This setLclEnv is important: the emitImplicationTcS uses that - -- TcLclEnv for the implication, and that in turn sets the location - -- for the Givens when solving the constraint (#21006) - do { let empty_subst = mkEmptySubst $ mkInScopeSet $ - tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - is_qc = IsQC (ctLocOrigin loc) - - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - -- Very like the code in tcSkolDFunType - ; rec { skol_info <- mkSkolemInfo skol_info_anon - ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs - ; let inst_pred = substTy subst pred - inst_theta = substTheta subst theta - skol_info_anon = InstSkol is_qc (get_size inst_pred) } - - ; given_ev_vars <- mapM newEvVar inst_theta - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) - -- Set the thing to prove to have a ScOrigin, so we are - -- careful about its termination checks. - -- See (QC-INV) in Note [Solving a Wanted forall-constraint] - ; wanted_ev <- newWantedEvVarNC loc' rewriters inst_pred - ; return ( ctEvEvId wanted_ev - , unitBag (mkNonCanonical wanted_ev)) } - - ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs - given_ev_vars wanteds - - ; setWantedEvTerm dest $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = ev_binds, et_body = w_id } - - ; stopWith ev "Wanted forall-constraint" } - where - -- Getting the size of the head is a bit horrible - -- because of the special treament for class predicates - get_size pred = case classifyPredType pred of - ClassPred cls tys -> pSizeClassPred cls tys - _ -> pSizeType pred - - -- See Note [Solving a Given forall-constraint] -solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc - = do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - where - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_pred = pred, qci_pend_sc = pend_sc } - -{- Note [Solving a Wanted forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a wanted forall (quantified) constraint - [W] df :: forall ab. (Eq a, Ord b) => C x a b -is delightfully easy. Just build an implication constraint - forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a -and discharge df thus: - df = /\ab. \g1 g2. let in d -where is filled in by solving the implication constraint. -All the machinery is to hand; there is little to do. - -The tricky point is about termination: see #19690. We want to maintain -the invariant (QC-INV): - - (QC-INV) Every quantified constraint returns a non-bottom dictionary - -just as every top-level instance declaration guarantees to return a non-bottom -dictionary. But as #19690 shows, it is possible to get a bottom dicionary -by superclass selection if we aren't careful. The situation is very similar -to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; -and we use the same solution: - -* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) -* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) - -Both of these things are done in solveForAll. Now the mechanism described -in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. - -Note [Solving a Given forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a Given constraint - [G] df :: forall ab. (Eq a, Ord b) => C x a b -we just add it to TcS's local InstEnv of known instances, -via addInertForall. Then, if we look up (C x Int Bool), say, -we'll find a match in the InstEnv. - -************************************************************************ -* * -* Equalities -* * -************************************************************************ - -Note [Canonicalising equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to canonicalise an equality, we look at the structure of the -two types at hand, looking for similarities. A difficulty is that the -types may look dissimilar before rewriting but similar after rewriting. -However, we don't just want to jump in and rewrite right away, because -this might be wasted effort. So, after looking for similarities and failing, -we rewrite and then try again. Of course, we don't want to loop, so we -track whether or not we've already rewritten. - -It is conceivable to do a better job at tracking whether or not a type -is rewritten, but this is left as future work. (Mar '15) - -Note [Decomposing FunTy] -~~~~~~~~~~~~~~~~~~~~~~~~ -can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This -means that we may very well have a FunTy containing a type of some -unknown kind. For instance, we may have, - - FunTy (a :: k) Int - -Where k is a unification variable. So the calls to splitRuntimeRep_maybe may -fail (returning Nothing). In that case we'll fall through, zonk, and try again. -Zonking should fill the variable k, meaning that decomposition will succeed the -second time around. - -Also note that we require the FunTyFlag to match. This will stop -us decomposing - (Int -> Bool) ~ (Show a => blah) -It's as if we treat (->) and (=>) as different type constructors, which -indeed they are! --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Right ty -> canEqReflexive ev eq_rel ty - Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2' - where - ev' | debugIsOn = setCtEvPredType ev $ - mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2' - | otherwise = ev - -- ev': satisfy the precondition of can_eq_nc - } - -can_eq_nc - :: Bool -- True => both types are rewritten - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) --- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2), --- without zonking --- This precondition is needed (only in DEBUG) to satisfy the assertions --- in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy - -can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ - vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } - -can_eq_nc' - :: Bool -- True => both input types are rewritten - -> GlobalRdrEnv -- needed to see which newtypes are in scope - -> FamInstEnvs -- needed to unwrap data instances - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) - --- See Note [Comparing nullary type synonyms] in GHC.Core.Type. -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2 - | tc1 == tc2 - = canEqReflexive ev eq_rel ty1 - --- Expand synonyms first; see Note [Type synonyms and canonicalization] -can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- coreView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- coreView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 - --- need to check for reflexivity in the ReprEq case. --- See Note [Eager reflexivity check] --- Check only when rewritten because the zonk_eq_types check in canEqNC takes --- care of the non-rewritten case. -can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _ - | ty1 `tcEqType` ty2 - = canEqReflexive ev ReprEq ty1 - --- When working with ReprEq, unwrap newtypes. --- See Note [Unwrap newtypes first] --- This must be above the TyVarTy case, in order to guarantee (TyEq:N) -can_eq_nc' _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | ReprEq <- eq_rel - , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 - = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2 - - | ReprEq <- eq_rel - , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 - = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1 - --- Then, get rid of casts -can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - | isNothing (canEqLHS_maybe ty2) -- See (3) in Note [Equalities with incompatible kinds] - = canEqCast rewritten ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 -can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - | isNothing (canEqLHS_maybe ty1) -- See (3) in Note [Equalities with incompatible kinds] - = canEqCast rewritten ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 - ----------------------- --- Otherwise try to decompose ----------------------- - --- Literals -can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ - | l1 == l2 - = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1) - ; stopWith ev "Equal LitTy" } - --- Decompose FunTy: (s -> t) and (c => t) --- NB: don't decompose (Int -> blah) ~ (Show a => blah) -can_eq_nc' _rewritten _rdr_env _envs ev eq_rel - (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1 - (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2 - | af1 == af2 -- See Note [Decomposing FunTy] - = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b) - --- Decompose type constructor applications --- NB: we have expanded type synonyms already -can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ - | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 - -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better - -- error messages rather than decomposing into AppTys; - -- hence no direct match on TyConApp - , not (isTypeFamilyTyCon tc1) - , not (isTypeFamilyTyCon tc2) - = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - -can_eq_nc' _rewritten _rdr_env _envs ev eq_rel - s1@(ForAllTy (Bndr _ vis1) _) _ - s2@(ForAllTy (Bndr _ vis2) _) _ - | vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality] - = can_eq_nc_forall ev eq_rel s1 s2 - --- See Note [Canonicalising type applications] about why we require rewritten types --- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families --- NB: Only decompose AppTy for nominal equality. --- See Note [Decomposing AppTy equalities] -can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _ - | Just (t1, s1) <- tcSplitAppTy_maybe ty1 - , Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev t1 s1 t2 s2 - -------------------- --- Can't decompose. -------------------- - --- No similarity in type structure detected. Rewrite and try again. -can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = -- Rewrite the two types and try again - do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1 - ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - ----------------------------- --- Look for a canonical LHS. See Note [Canonical LHS]. --- Only rewritten types end up below here. ----------------------------- - --- NB: pattern match on True: we want only rewritten types sent to canEqLHS --- This means we've rewritten any variables and reduced any type family redexes --- See also Note [No top-level newtypes on RHS of representational equalities] -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just can_eq_lhs1 <- canEqLHS_maybe ty1 - = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 - - | Just can_eq_lhs2 <- canEqLHS_maybe ty2 - = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1 - - -- If the type is TyConApp tc1 args1, then args1 really can't be less - -- than tyConArity tc1. It could be *more* than tyConArity, but then we - -- should have handled the case as an AppTy. That case only fires if - -- _both_ sides of the equality are AppTy-like... but if one side is - -- AppTy-like and the other isn't (and it also isn't a variable or - -- saturated type family application, both of which are handled by - -- can_eq_nc'), we're in a failure mode and can just fall through. - ----------------------------- --- Fall-through. Give up. ----------------------------- - --- We've rewritten and the types don't match. Give up. -can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) - ; case eq_rel of -- See Note [Unsolved equalities] - ReprEq -> continueWith (mkIrredCt ReprEqReason ev) - NomEq -> continueWith (mkIrredCt ShapeMismatchReason ev) } - -- No need to call canEqFailure/canEqHardFailure because they - -- rewrite, and the types involved here are already rewritten - - -{- Note [Unsolved equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved equality like - (a b ~R# Int) -that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. -So we want to make it a potentially-soluble Irred not an insoluble one. -Missing this point is what caused #15431 --} - ---------------------------------- -can_eq_nc_forall :: CtEvidence -> EqRel - -> Type -> Type -- LHS and RHS - -> TcS (StopOrContinue Ct) --- (forall as. phi1) ~ (forall bs. phi2) --- Check for length match of as, bs --- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] --- But remember also to unify the kinds of as and bs --- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] --- Remember also that we might have forall z (a:z). blah --- so we must proceed one binder at a time (#13879) - -can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev - = do { let free_tvs = tyCoVarsOfTypes [s1,s2] - (bndrs1, phi1) = tcSplitForAllTyVarBinders s1 - (bndrs2, phi2) = tcSplitForAllTyVarBinders s2 - ; if not (equalLength bndrs1 bndrs2) - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (binderFlags bndrs1) - , ppr (binderFlags bndrs2) ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs - ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ - binderVars bndrs1 - - ; let phi1' = substTy subst1 phi1 - - -- Unify the kinds, extend the substitution - go :: [TcTyVar] -> Subst -> [TyVarBinder] - -> TcS (TcCoercion, Cts) - go (skol_tv:skol_tvs) subst (bndr2:bndrs2) - = do { let tv2 = binderVar bndr2 - ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv) - (substTy subst (tyVarKind tv2)) - ; let subst' = extendTvSubstAndInScope subst tv2 - (mkCastTy (mkTyVarTy skol_tv) kind_co) - -- skol_tv is already in the in-scope set, but the - -- free vars of kind_co are not; hence "...AndInScope" - ; (co, wanteds2) <- go skol_tvs subst' bndrs2 - ; return ( mkForAllCo skol_tv kind_co co - , wanteds1 `unionBags` wanteds2 ) } - - -- Done: unify phi1 ~ phi2 - go [] subst bndrs2 - = assert (null bndrs2) $ - unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) - - go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - - empty_subst2 = mkEmptySubst (getSubstInScope subst1) - - ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds - - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } - - | otherwise - = do { traceTcS "Omitting decomposition of given polytype equality" $ - pprEq s1 s2 -- See Note [Do not decompose Given polytype equalities] - ; stopWith ev "Discard given polytype equality" } - - where - unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) - -- This version returns the wanted constraint rather - -- than putting it in the work list - unify loc rewriters role ty1 ty2 - | ty1 `tcEqType` ty2 - = return (mkReflCo role ty1, emptyBag) - | otherwise - = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2 - ; return (co, unitBag (mkNonCanonical wanted)) } - ---------------------------------- --- | Compare types for equality, while zonking as necessary. Gives up --- as soon as it finds that two types are not equal. --- This is quite handy when some unification has made two --- types in an inert Wanted to be equal. We can discover the equality without --- rewriting, which is sometimes very expensive (in the case of type functions). --- In particular, this function makes a ~20% improvement in test case --- perf/compiler/T5030. --- --- Returns either the (partially zonked) types in the case of --- inequality, or the one type in the case of equality. canEqReflexive is --- a good next step in the 'Right' case. Returning 'Left' is always safe. --- --- NB: This does *not* look through type synonyms. In fact, it treats type --- synonyms as rigid constructors. In the future, it might be convenient --- to look at only those arguments of type synonyms that actually appear --- in the synonym RHS. But we're not there yet. -zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) -zonk_eq_types = go - where - go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 - go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 - go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 - - -- We handle FunTys explicitly here despite the fact that they could also be - -- treated as an application. Why? Well, for one it's cheaper to just look - -- at two types (the argument and result types) than four (the argument, - -- result, and their RuntimeReps). Also, we haven't completely zonked yet, - -- so we may run into an unzonked type variable while trying to compute the - -- RuntimeReps of the argument and result types. This can be observed in - -- testcase tc269. - go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2) - | af1 == af2 - , eqType w1 w2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev (FunTy af1 w1) res_b res_a } - - go ty1@(FunTy {}) ty2 = bale_out ty1 ty2 - go ty1 ty2@(FunTy {}) = bale_out ty1 ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1 - , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2 - = if tc1 == tc2 && tys1 `equalLength` tys2 - -- Crucial to check for equal-length args, because - -- we cannot assume that the two args to 'go' have - -- the same kind. E.g go (Proxy * (Maybe Int)) - -- (Proxy (*->*) Maybe) - -- We'll call (go (Maybe Int) Maybe) - -- See #13083 - then tycon tc1 tys1 tys2 - else bale_out ty1 ty2 - - go ty1 ty2 - | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 - , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 - = do { res_a <- go ty1a ty2a - ; res_b <- go ty1b ty2b - ; return $ combine_rev mkAppTy res_b res_a } - - go ty1@(LitTy lit1) (LitTy lit2) - | lit1 == lit2 - = return (Right ty1) - - go ty1 ty2 = bale_out ty1 ty2 - -- We don't handle more complex forms here - - bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) - - tyvar :: SwapFlag -> TcTyVar -> TcType - -> TcS (Either (Pair TcType) TcType) - -- Try to do as little as possible, as anything we do here is redundant - -- with rewriting. In particular, no need to zonk kinds. That's why - -- we don't use the already-defined zonking functions - tyvar swapped tv ty - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> give_up - Indirect ty' -> do { trace_indirect tv ty' - ; unSwap swapped go ty' ty } } - _ -> give_up - where - give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty - - tyvar_tyvar tv1 tv2 - | tv1 == tv2 = return (Right (mkTyVarTy tv1)) - | otherwise = do { (ty1', progress1) <- quick_zonk tv1 - ; (ty2', progress2) <- quick_zonk tv2 - ; if progress1 || progress2 - then go ty1' ty2' - else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } - - trace_indirect tv ty - = traceTcS "Following filled tyvar (zonk_eq_types)" - (ppr tv <+> equals <+> ppr ty) - - quick_zonk tv = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> return (TyVarTy tv, False) - Indirect ty' -> do { trace_indirect tv ty' - ; return (ty', True) } } - _ -> return (TyVarTy tv, False) - - -- This happens for type families, too. But recall that failure - -- here just means to try harder, so it's OK if the type function - -- isn't injective. - tycon :: TyCon -> [TcType] -> [TcType] - -> TcS (Either (Pair TcType) TcType) - tycon tc tys1 tys2 - = do { results <- zipWithM go tys1 tys2 - ; return $ case combine_results results of - Left tys -> Left (mkTyConApp tc <$> tys) - Right tys -> Right (mkTyConApp tc tys) } - - combine_results :: [Either (Pair TcType) TcType] - -> Either (Pair [TcType]) [TcType] - combine_results = bimap (fmap reverse) reverse . - foldl' (combine_rev (:)) (Right []) - - -- combine (in reverse) a new result onto an already-combined result - combine_rev :: (a -> b -> c) - -> Either (Pair b) b - -> Either (Pair a) a - -> Either (Pair c) c - combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) - combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) - combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) - combine_rev f (Right tys) (Right ty) = Right (f ty tys) - -{- Note [Unwrap newtypes first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Decomposing newtype equalities] - -Consider - newtype N m a = MkN (m a) -N will get a conservative, Nominal role for its second parameter 'a', -because it appears as an argument to the unknown 'm'. Now consider - [W] N Maybe a ~R# N Maybe b - -If we /decompose/, we'll get - [W] a ~N# b - -But if instead we /unwrap/ we'll get - [W] Maybe a ~R# Maybe b -which in turn gives us - [W] a ~R# b -which is easier to satisfy. - -Conclusion: we must unwrap newtypes before decomposing them. This happens -in `can_eq_newtype_nc` - -We did flirt with making the /rewriter/ expand newtypes, rather than -doing it in `can_eq_newtype_nc`. But with recursive newtypes we want -to be super-careful about expanding! - - newtype A = MkA [A] -- Recursive! - - f :: A -> [A] - f = coerce - -We have [W] A ~R# [A]. If we rewrite [A], it'll expand to - [[[[[...]]]]] -and blow the reduction stack. See Note [Newtypes can blow the stack] -in GHC.Tc.Solver.Rewrite. But if we expand only the /top level/ of -both sides, we get - [W] [A] ~R# [A] -which we can, just, solve by reflexivity. - -So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`. - -This is all very delicate. There is a real risk of a loop in the type checker -with recursive newtypes -- but I think we're doomed to do *something* -delicate, as we're really trying to solve for equirecursive type -equality. Bottom line for users: recursive newtypes do not play well with type -inference for representational equality. See also Section 5.3.1 and 5.3.4 of -"Safe Zero-cost Coercions for Haskell" (JFP 2016). - -See also Note [Decomposing newtype equalities]. - ---- Historical side note --- - -We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply; -see #22519. But that didn't work: see discussion in #22924. Specifically -we got a loop with a minor variation: - f2 :: a -> [A] - f2 = coerce - -Note [Eager reflexivity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - -and - - [W] X ~R X - -Naively, we would start unwrapping X and end up in a loop. Instead, -we do this eager reflexivity check. This is necessary only for representational -equality because the rewriter technology deals with the similar case -(recursive type families) for nominal equality. - -Note that this check does not catch all cases, but it will catch the cases -we're most worried about, types like X above that are actually inhabited. - -Here's another place where this reflexivity check is key: -Consider trying to prove (f a) ~R (f a). The AppTys in there can't -be decomposed, because representational equality isn't congruent with respect -to AppTy. So, when canonicalising the equality above, we get stuck and -would normally produce a CIrredCan. However, we really do want to -be able to solve (f a) ~R (f a). So, in the representational case only, -we do a reflexivity check. - -(This would be sound in the nominal case, but unnecessary, and I [Richard -E.] am worried that it would slow down the common case.) - - Note [Newtypes can blow the stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - newtype Y = MkY (Int -> Y) - -and now wish to prove - - [W] X ~R Y - -This Wanted will loop, expanding out the newtypes ever deeper looking -for a solid match or a solid discrepancy. Indeed, there is something -appropriate to this looping, because X and Y *do* have the same representation, -in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized -coercion will ever witness it. This loop won't actually cause GHC to hang, -though, because we check our depth in `can_eq_newtype_nc`. --} - ------------------------- --- | We're able to unwrap a newtype. Update the bits accordingly. -can_eq_newtype_nc :: CtEvidence -- ^ :: ty1 ~ ty2 - -> SwapFlag - -> TcType -- ^ ty1 - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' - -> TcType -- ^ ty2 - -> TcType -- ^ ty2, with type synonyms - -> TcS (StopOrContinue Ct) -can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 - = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ] - - -- Check for blowing our stack, and increase the depth - -- See Note [Newtypes can blow the stack] - ; let loc = ctEvLoc ev - ev' = ev `setCtEvLoc` bumpCtLocDepth loc - ; checkReductionDepth loc ty1 - - -- Next, we record uses of newtype constructors, since coercing - -- through newtypes is tantamount to using their constructors. - ; recordUsedGREs gres - - ; let redn1 = mkReduction co1 ty1' - - ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped - redn1 - (mkReflRedn Representational ps_ty2) - ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } - ---------- --- ^ Decompose a type application. --- All input types must be rewritten. See Note [Canonicalising type applications] --- Nominal equality only! -can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 - -> Xi -> Xi -- s1 t1 - -> Xi -> Xi -- s2 t2 - -> TcS (StopOrContinue Ct) - --- AppTys only decompose for nominal equality, so this case just leads --- to an irreducible constraint; see typecheck/should_compile/T10494 --- See Note [Decomposing AppTy equalities] -can_eq_app ev s1 t1 s2 t2 - | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev - = do { co_s <- unifyWanted rewriters loc Nominal s1 s2 - ; let arg_loc - | isNextArgVisible s1 = loc - | otherwise = updateCtLocOrigin loc toInvisibleOrigin - ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2 - ; let co = mkAppCo co_s co_t - ; setWantedEq dest co - ; stopWith ev "Decomposed [W] AppTy" } - - -- If there is a ForAll/(->) mismatch, the use of the Left coercion - -- below is ill-typed, potentially leading to a panic in splitTyConApp - -- Test case: typecheck/should_run/Typeable1 - -- We could also include this mismatch check above (for W and D), but it's slow - -- and we'll get a better error message not doing it - | s1k `mismatches` s2k - = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) - - | CtGiven { ctev_evar = evar } <- ev - = do { let co = mkCoVarCo evar - co_s = mkLRCo CLeft co - co_t = mkLRCo CRight co - ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 - , evCoercion co_s ) - ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 - , evCoercion co_t ) - ; emitWorkNC [evar_t] - ; canEqNC evar_s NomEq s1 s2 } - - where - loc = ctEvLoc ev - - s1k = typeKind s1 - s2k = typeKind s2 - - k1 `mismatches` k2 - = isForAllTy k1 && not (isForAllTy k2) - || not (isForAllTy k1) && isForAllTy k2 - ------------------------ --- | Break apart an equality over a casted type --- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) -canEqCast :: Bool -- are both types rewritten? - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue Ct) -canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2 - = do { traceTcS "Decomposing cast" (vcat [ ppr ev - , ppr ty1 <+> text "|>" <+> ppr co1 - , ppr ps_ty2 ]) - ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkGReflLeftRedn role ty1 co1) - (mkReflRedn role ps_ty2) - ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel - ------------------------- -canTyConApp :: CtEvidence -> EqRel - -> TyCon -> [TcType] - -> TyCon -> [TcType] - -> TcS (StopOrContinue Ct) --- See Note [Decomposing TyConApp equalities] --- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities] --- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family --- But they can be data families. -canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - | tc1 == tc2 - , tys1 `equalLength` tys2 - = do { inerts <- getTcSInerts - ; if can_decompose inerts - then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - else canEqFailure ev eq_rel ty1 ty2 } - - -- See Note [Skolem abstract data] in GHC.Core.Tycon - | tyConSkolem tc1 || tyConSkolem tc2 - = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; continueWith (mkIrredCt AbstractTyConReason ev) } - - -- Fail straight away for better error messages - -- See Note [Use canEqFailure in canDecomposableTyConApp] - | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && - isGenerativeTyCon tc2 Representational) - = canEqFailure ev eq_rel ty1 ty2 - - | otherwise - = canEqHardFailure ev ty1 ty2 - where - -- Reconstruct the types for error messages. This would do - -- the wrong thing (from a pretty printing point of view) - -- for functions, because we've lost the FunTyFlag; but - -- in fact we never call canTyConApp on a saturated FunTyCon - ty1 = mkTyConApp tc1 tys1 - ty2 = mkTyConApp tc2 tys2 - - -- See Note [Decomposing TyConApp equalities] - -- and Note [Decomposing newtype equalities] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (assert (eq_rel == ReprEq) $ - -- assert: isInjectiveTyCon is always True for Nominal except - -- for type synonyms/families, neither of which happen here - -- Moreover isInjectiveTyCon is True for Representational - -- for algebraic data types. So we are down to newtypes - -- and data families. - ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts) - -- See Note [Decomposing newtype equalities] (EX2) - -{- -Note [Use canEqFailure in canDecomposableTyConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must use canEqFailure, not canEqHardFailure here, because there is -the possibility of success if working with a representational equality. -Here is one case: - - type family TF a where TF Char = Bool - data family DF a - newtype instance DF Bool = MkDF Int - -Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet -know `a`. This is *not* a hard failure, because we might soon learn -that `a` is, in fact, Char, and then the equality succeeds. - -Here is another case: - - [G] Age ~R Int - -where Age's constructor is not in scope. We don't want to report -an "inaccessible code" error in the context of this Given! - -For example, see typecheck/should_compile/T10493, repeated here: - - import Data.Ord (Down) -- no constructor - - foo :: Coercible (Down Int) Int => Down Int -> Int - foo = coerce - -That should compile, but only because we use canEqFailure and not -canEqHardFailure. - -Note [Fast path when decomposing TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (T s1 t1 ~ T s2 t2), then we can just decompose to - (s1 ~ s2, t1 ~ t2) -and push those back into the work list. But if - s1 = K k1 s2 = K k2 -then we will just decompose s1~s2, and it might be better to -do so on the spot. An important special case is where s1=s2, -and we get just Refl. - -So canDecomposableTyConAppOK uses unifyWanted etc to short-cut that work. -See also Note [Decomposing Dependent TyCons and Processing Wanted Equalities] - -Note [Decomposing TyConApp equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - [G/W] T ty1 ~r T ty2 -Can we decompose it, and replace it by - [G/W] ty1 ~r' ty2 -and if so what role is r'? (In this Note, all the "~" are primitive -equalities "~#", but I have dropped the noisy "#" symbols.) Lots of -background in the paper "Safe zero-cost coercions for Haskell". - -This Note covers the topic for - * Datatypes - * Newtypes - * Data families -For the rest: - * Type synonyms: are always expanded - * Type families: see Note [Decomposing type family applications] - * AppTy: see Note [Decomposing AppTy equalities]. - ----- Roles of the decomposed constraints ---- -For a start, the role r' will always be defined like this: - * If r=N then r' = N - * If r=R then r' = role of T's first argument - -For example: - data TR a = MkTR a -- Role of T's first arg is Representational - data TN a = MkTN (F a) -- Role of T's first arg is Nominal - -The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument -role r' for a TyCon T at role r. E.g. - tyConRolesX Nominal TR = [Nominal] - tyConRolesX Representational TR = [Representational] - ----- Soundness and completeness ---- -For Givens, for /soundness/ of decomposition we need, forall ty1,ty2: - T ty1 ~r T ty2 ===> ty1 ~r' ty2 -Here "===>" means "implies". That is, given evidence for (co1 : T ty1 ~r T co2) -we can produce evidence for (co2 : ty1 ~r' ty2). But in the solver we -/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs -thereby. So for /completeness/ of decomposition we also need the reverse: - ty1 ~r' ty2 ===> T ty1 ~r T ty2 - -For Wanteds, for /soundness/ of decomposition we need: - ty1 ~r' ty2 ===> T ty1 ~r T ty2 -because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and -from that we want to derive evidence (T co2 : T ty1 ~r T ty2). -For /completeness/ of decomposition we need the reverse implication too, -else we may decompose to a new proof obligation that is stronger than -the one we started with. See Note [Decomposing newtype equalities]. - ----- Injectivity ---- -When do these bi-implications hold? In one direction it is easy. -We /always/ have - ty1 ~r' ty2 ===> T ty1 ~r T ty2 -This is the CO_TYCONAPP rule of the paper (Fig 5); see also the -TyConAppCo case of GHC.Core.Lint.lintCoercion. - -In the other direction, we have - T ty1 ~r T ty2 ==> ty1 ~r' ty2 if T is /injective at role r/ -This is the very /definition/ of injectivity: injectivity means result -is the same => arguments are the same, modulo the role shift. -See comments on GHC.Core.TyCon.isInjectiveTyCon. This is also -the CO_NTH rule in Fig 5 of the paper, except in the paper only -newtypes are non-injective at representation role, so the rule says "H -is not a newtype". - -Injectivity is a bit subtle: - Nominal Representational - Datatype YES YES - Newtype YES NO{1} - Data family YES NO{2} - -{1} Consider newtype N a = MkN (F a) -- Arg has Nominal role - Is it true that (N t1) ~R (N t2) ==> t1 ~N t2 ? - No, absolutely not. E.g. - type instance F Int = Int; type instance F Bool = Char - Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char! - - See Note [Decomposing newtype equalities] - -{2} We must treat data families precisely like newtypes, because of the - possibility of newtype instances. See also - Note [Decomposing newtype equalities]. See #10534 and - test case typecheck/should_fail/T10534. - ----- Takeaway summary ----- -For sound and complete decomposition, we simply need injectivity; -that is for isInjectiveTyCon to be true: - -* At Nominal role, isInjectiveTyCon is True for all the TyCons we are - considering in this Note: datatypes, newtypes, and data families. - -* For Givens, injectivity is necessary for soundness; completeness has no - side conditions. - -* For Wanteds, soundness has no side conditions; but injectivity is needed - for completeness. See Note [Decomposing newtype equalities] - -This is implemented in `can_decompose` in `canTyConApp`; it looks at -injectivity, just as specified above. - - -Note [Decomposing type family applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose we have - [G/W] (F ty1) ~r (F ty2) -This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2. - -We never decompose to - [G/W] ty1 ~r' ty2 - -Instead - -* For Givens we do nothing. Injective type families have no corresponding - evidence of their injectivity, so we cannot decompose an - injective-type-family Given. - -* For Wanteds, for the Nominal role only, we emit new Wanteds rather like - functional dependencies, for each injective argument position. - - E.g type family F a b -- injective in first arg, but not second - [W] (F s1 t1) ~N (F s2 t2) - Emit new Wanteds - [W] s1 ~N s2 - But retain the existing, unsolved constraint. - -Note [Decomposing newtype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note also applies to data families, which we treat like -newtype in case of 'newtype instance'. - -As Note [Decomposing TyConApp equalities] describes, if N is injective -at role r, we can do this decomposition? - [G/W] (N ty1) ~r (N ty2) to [G/W] ty1 ~r' ty2 - -For a Given with r=R, the answer is a solid NO: newtypes are not injective at -representational role, and we must not decompose, or we lose soundness. -Example is wrinkle {1} in Note [Decomposing TyConApp equalities]. - -For a Wanted with r=R, since newtypes are not injective at representational -role, decomposition is sound, but we may lose completeness. Nevertheless, -if the newtype is abstract (so can't be unwrapped) we can only solve -the equality by (a) using a Given or (b) decomposition. If (a) is impossible -(e.g. no Givens) then (b) is safe albeit potentially incomplete. - -There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete: - -* Incompleteness example (EX1): unwrap first - newtype Nt a = MkNt (Id a) - type family Id a where Id a = a - - [W] Nt Int ~R Nt Age - - Because of its use of a type family, Nt's parameter will get inferred to - have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, - which is unsatisfiable. Unwrapping, though, leads to a solution. - - Conclusion: always unwrap newtypes before attempting to decompose - them. This is done in can_eq_nc'. Of course, we can't unwrap if the data - constructor isn't in scope. See Note [Unwrap newtypes first]. - -* Incompleteness example (EX2): available Givens - newtype Nt a = Mk Bool -- NB: a is not used in the RHS, - type role Nt representational -- but the user gives it an R role anyway - - [G] Nt t1 ~R Nt t2 - [W] Nt alpha ~R Nt beta - - We *don't* want to decompose to [W] alpha ~R beta, because it's possible - that alpha and beta aren't representationally equal. And if we figure - out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted - from the Given. This is somewhat similar to the question of overlapping - Givens for class constraints: see Note [Instance and Given overlap] in - GHC.Tc.Solver.Interact. - - Conclusion: don't decompose [W] N s ~R N t, if there are any Given - equalities that could later solve it. - - But what precisely does it mean to say "any Given equalities that could - later solve it"? - - In #22924 we had - [G] f a ~R# a [W] Const (f a) a ~R# Const a a - where Const is an abstract newtype. If we decomposed the newtype, we - could solve. Not-decomposing on the grounds that (f a ~R# a) might turn - into (Const (f a) a ~R# Const a a) seems a bit silly. - - In #22331 we had - [G] N a ~R# N b [W] N b ~R# N a - (where N is abstract so we can't unwrap). Here we really /don't/ want to - decompose, because the /only/ way to solve the Wanted is from that Given - (with a Sym). - - In #22519 we had - [G] a <= b [W] IO Age ~R# IO Int - - (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=) - is a type-level comparison on Nats). Here we /must/ decompose, despite the - existence of an Irred Given, or we will simply be stuck. (Side note: We - flirted with deep-rewriting of newtypes (see discussion on #22519 and - !9623) but that turned out not to solve #22924, and also makes type - inference loop more often on recursive newtypes.) - - The currently-implemented compromise is this: - - we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t' - - that is, a Given Irred equality with both sides headed with N. - See the call to noGivenNewtypeReprEqs in canTyConApp. - - This is not perfect. In principle a Given like [G] (a b) ~ (c d), or - even just [G] c, could later turn into N s ~ N t. But since the free - vars of a Given are skolems, or at least untouchable unification - variables, this is extremely unlikely to happen. - - Another worry: there could, just, be a CDictCan with some - un-expanded equality superclasses; but only in some very obscure - recursive-superclass situations. - - Yet another approach (!) is desribed in - Note [Decomposing newtypes a bit more aggressively]. - -Remember: decomposing Wanteds is always /sound/. This Note is -only about /completeness/. - -Note [Decomposing newtypes a bit more aggressively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IMPORTANT: the ideas in this Note are *not* implemented. Instead, the -current approach is detailed in Note [Decomposing newtype equalities] -and Note [Unwrap newtypes first]. -For more details about the ideas in this Note see - * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549 - * issue #22441 - * discussion on !9282. - -Consider [G] c, [W] (IO Int) ~R (IO Age) -where IO is abstract, and - newtype Age = MkAge Int -- Not abstract -With the above rules, if there any Given Irreds, -the Wanted is insoluble because we can't decompose it. But in fact, -if we look at the defn of IO, roughly, - newtype IO a = State# -> (State#, a) -we can see that decomposing [W] (IO Int) ~R (IO Age) to - [W] Int ~R Age -definitely does not lose completeness. Why not? Because the role of -IO's argment is representational. Hence: - - DecomposeNewtypeIdea: - decompose [W] (N s1 .. sn) ~R (N t1 .. tn) - if the roles of all N's arguments are representational - -If N's arguments really /are/ representational this will not lose -completeness. Here "really are representational" means "if you expand -all newtypes in N's RHS, we'd infer a representational role for each -of N's type variables in that expansion". See Note [Role inference] -in GHC.Tc.TyCl.Utils. - -But the user might /override/ a phantom role with an explicit role -annotation, and then we could (obscurely) get incompleteness. -Consider - - module A( silly, T ) where - newtype T a = MkT Int - type role T representational -- Override phantom role - - silly :: Coercion (T Int) (T Bool) - silly = Coercion -- Typechecks by unwrapping the newtype - - data Coercion a b where -- Actually defined in Data.Type.Coercion - Coercion :: Coercible a b => Coercion a b - - module B where - import A - f :: T Int -> T Bool - f = case silly of Coercion -> coerce - -Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose, -we'll get stuck with (Int ~R Bool). Instead we want to use the -[G] (T Int) ~R (T Bool), which will be in the Irreds. - -Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very -obscure incompleteness (above). But no one is reporting a problem from -the lack of decompostion, so we'll just leave it for now. This long -Note is just to record the thinking for our future selves. - -Note [Decomposing AppTy equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For AppTy all the same questions arise as in -Note [Decomposing TyConApp equalities]. We have - - s1 ~r s2, t1 ~N t2 ==> s1 t1 ~r s2 t2 (rule CO_APP) - s1 t1 ~N s2 t2 ==> s1 ~N s2, t1 ~N t2 (CO_LEFT, CO_RIGHT) - -In the first of these, why do we need Nominal equality in (t1 ~N t2)? -See {2} below. - -For sound and complete solving, we need both directions to decompose. So: -* At nominal role, all is well: we have both directions. -* At representational role, decomposition of Givens is unsound (see {1} below), - and decomposition of Wanteds is incomplete. - -Here is an example of the incompleteness for Wanteds: - - [G] g1 :: a ~R b - [W] w1 :: Maybe b ~R alpha a - [W] w2 :: alpha ~N Maybe - -Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get - - w1 := AppCo w3 w4 - [W] w3 :: Maybe ~R alpha - [W] w4 :: b ~N a - -Note that w4 is *nominal*. A nominal role here is necessary because AppCo -requires a nominal role on its second argument. (See {2} for an example of -why.) Now we are stuck, because w4 is insoluble. On the other hand, if we -see w2 first, setting alpha := Maybe, all is well, as we can decompose -Maybe b ~R Maybe a into b ~R a. - -Another example: - newtype Phant x = MkPhant Int - [W] w1 :: Phant Int ~R alpha Bool - [W] w2 :: alpha ~ Phant - -If we see w1 first, decomposing would be disastrous, as we would then try -to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become - [W] w1' :: Phant Int ~R Phant Bool - -which can then (assuming MkPhant is in scope) be simplified to Int ~R Int, -and all will be well. See also Note [Unwrap newtypes first]. - -Bottom line: -* Always decompose AppTy at nominal role: can_eq_app -* Never decompose AppTy at representational role (neither Given nor Wanted): - the lack of an equation in can_eq_nc' - -Extra points -{1} Decomposing a Given AppTy over a representational role is simply - unsound. For example, if we have co1 :: Phant Int ~R a Bool (for - the newtype Phant, above), then we surely don't want any relationship - between Int and Bool, lest we also have co2 :: Phant ~ a around. - -{2} The role on the AppCo coercion is a conservative choice, because we don't - know the role signature of the function. For example, let's assume we could - have a representational role on the second argument of AppCo. Then, consider - - data G a where -- G will have a nominal role, as G is a GADT - MkG :: G Int - newtype Age = MkAge Int - - co1 :: G ~R a -- by assumption - co2 :: Age ~R Int -- by newtype axiom - co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo - - and now co3 can be used to cast MkG to have type G Age, in violation of - the way GADTs are supposed to work (which is to use nominal equality). --} - -canDecomposableTyConAppOK :: CtEvidence -> EqRel - -> TyCon -> [TcType] -> [TcType] - -> TcS (StopOrContinue Ct) --- Precondition: tys1 and tys2 are the same finite length, hence "OK" -canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 - = assert (tys1 `equalLength` tys2) $ - do { traceTcS "canDecomposableTyConAppOK" - (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) - ; case ev of - CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } - -- new_locs and tc_roles are both infinite, so - -- we are guaranteed that cos has the same lengthm - -- as tys1 and tys2 - -- See Note [Fast path when decomposing TyConApps] - -- Caution: unifyWanteds is order sensitive - -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities] - -> do { cos <- unifyWanteds rewriters new_locs tc_roles tys1 tys2 - ; setWantedEq dest (mkTyConAppCo role tc cos) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole r ty1 ty2 - , evCoercion $ mkSelCo (SelTyCon i r) ev_co ) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - ; emitWorkNC given_evs } - - ; stopWith ev "Decomposed TyConApp" } - - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - - -- Infinite, to allow for over-saturated TyConApps - tc_roles = tyConRoleListX role tc - - -- Add nuances to the location during decomposition: - -- * if the argument is a kind argument, remember this, so that error - -- messages say "kind", not "type". This is determined based on whether - -- the corresponding tyConBinder is named (that is, dependent) - -- * if the argument is invisible, note this as well, again by - -- looking at the corresponding binder - -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't - -- do either of these changes. (Forgetting to do so led to #16188) - -- - -- NB: infinite in length - new_locs = [ new_loc - | bndr <- tyConBinders tc - , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc - | otherwise = loc - new_loc | isInvisibleTyConBinder bndr - = updateCtLocOrigin new_loc0 toInvisibleOrigin - | otherwise - = new_loc0 ] - ++ repeat loc - -canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag - -> (Type,Type,Type) -- (multiplicity,arg,res) - -> (Type,Type,Type) -- (multiplicity,arg,res) - -> TcS (StopOrContinue Ct) -canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2) - = do { traceTcS "canDecomposableFunTy" - (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) - ; case ev of - CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } - -> do { mult <- unifyWanted rewriters mult_loc (funRole role SelMult) m1 m2 - ; arg <- unifyWanted rewriters loc (funRole role SelArg) a1 a2 - ; res <- unifyWanted rewriters loc (funRole role SelRes) r1 r2 - ; setWantedEq dest (mkNakedFunCo1 role af mult arg res) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole role' ty1 ty2 - , evCoercion $ mkSelCo (SelFun fs) ev_co ) - | (fs, ty1, ty2) <- [(SelMult, m1, m2) - ,(SelArg, a1, a2) - ,(SelRes, r1, r2)] - , let role' = funRole role fs ] - ; emitWorkNC given_evs } - - ; stopWith ev "Decomposed TyConApp" } - - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - mult_loc = updateCtLocOrigin loc toInvisibleOrigin - --- | Call when canonicalizing an equality fails, but if the equality is --- representational, there is some hope for the future. --- Examples in Note [Use canEqFailure in canDecomposableTyConApp] -canEqFailure :: CtEvidence -> EqRel - -> TcType -> TcType -> TcS (StopOrContinue Ct) -canEqFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqFailure ev ReprEq ty1 ty2 - = do { (redn1, rewriters1) <- rewrite ev ty1 - ; (redn2, rewriters2) <- rewrite ev ty2 - -- We must rewrite the types before putting them in the - -- inert set, so that we are sure to kick them out when - -- new equalities become available - ; traceTcS "canEqFailure with ReprEq" $ - vcat [ ppr ev, ppr redn1, ppr redn2 ] - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; continueWith (mkIrredCt ReprEqReason new_ev) } - --- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence - -> TcType -> TcType -> TcS (StopOrContinue Ct) --- See Note [Make sure that insolubles are fully rewritten] -canEqHardFailure ev ty1 ty2 - = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) - ; (redn1, rewriters1) <- rewriteForErrors ev ty1 - ; (redn2, rewriters2) <- rewriteForErrors ev ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; continueWith (mkIrredCt ShapeMismatchReason new_ev) } - -{- -Note [Canonicalising type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (s1 t1) ~ ty2, how should we proceed? -The simple thing is to see if ty2 is of form (s2 t2), and -decompose. - -However, over-eager decomposition gives bad error messages -for things like - a b ~ Maybe c - e f ~ p -> q -Suppose (in the first example) we already know a~Array. Then if we -decompose the application eagerly, yielding - a ~ Maybe - b ~ c -we get an error "Can't match Array ~ Maybe", -but we'd prefer to get "Can't match Array b ~ Maybe c". - -So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of -replacing (a b) by (Array b), before using try_decompose_app to -decompose it. - -Note [Make sure that insolubles are fully rewritten] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When an equality fails, we still want to rewrite the equality -all the way down, so that it accurately reflects - (a) the mutable reference substitution in force at start of solving - (b) any ty-binds in force at this point in solving -See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. -And if we don't do this there is a bad danger that -GHC.Tc.Solver.applyTyVarDefaulting will find a variable -that has in fact been substituted. - -Note [Do not decompose Given polytype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? -No -- what would the evidence look like? So instead we simply discard -this given evidence. - -Note [No top-level newtypes on RHS of representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we're in this situation: - - work item: [W] c1 : a ~R b - inert: [G] c2 : b ~R Id a - -where - newtype Id a = Id a - -We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten -and the Id newtype is unwrapped. This is assured by requiring only rewritten -types in canEqCanLHS *and* having the newtype-unwrapping check above -the tyvar check in can_eq_nc. - -Note that this only applies to saturated applications of newtype TyCons, as -we can't rewrite an unsaturated application. See for example T22310, where -we ended up with: - - newtype Compose f g a = ... - - [W] t[tau] ~# Compose Foo Bar - -Note [Put touchable variables on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticket #10009, a very nasty example: - - f :: (UnF (F b) ~ b) => F b -> () - - g :: forall a. (UnF (F a) ~ a) => a -> () - g _ = f (undefined :: F a) - -For g we get [G] g1 : UnF (F a) ~ a - [W] w1 : UnF (F beta) ~ beta - [W] w2 : F a ~ F beta - -g1 is canonical (CEqCan). It is oriented as above because a is not touchable. -See canEqTyVarFunEq. - -w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key -here. - -w2 is canonical. But which way should it be oriented? As written, we'll be -stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is -a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS -of w2. We'll thus lose. - -But if w2 is swapped around, to - - [W] w3 : F beta ~ F a - -then we'll kick w1 out of the inert -set (it mentions the LHS of w3). We then rewrite w1 to - - [W] w4 : UnF (F a) ~ beta - -and then, using g1, to - - [W] w5 : a ~ beta - -at which point we can unify and go on to glory. (This rewriting actually -happens all at once, in the call to rewrite during canonicalisation.) - -But what about the new LHS makes it better? It mentions a variable (beta) -that can appear in a Wanted -- a touchable metavariable never appears -in a Given. On the other hand, the original LHS mentioned only variables -that appear in Givens. We thus choose to put variables that can appear -in Wanteds on the left. - -Ticket #12526 is another good example of this in action. - --} - ---------------------- -canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- lhs: pretty lhs, already rewritten - -> TcType -> TcType -- rhs: already rewritten - -> TcS (StopOrContinue Ct) -canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 - | k1 `tcEqType` k2 - = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 - - | otherwise - = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2 - - where - k1 = canEqLHSKind lhs1 - k2 = typeKind xi2 - - -{- -Note [Kind Equality Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in practice it does not. -See Note [Fundeps with instances, and equality orientation] where this is discussed at length. -As a rule of thumb: we keep the newest unification variables on the left of the equality. -See also Note [Improvement orientation] in GHC.Tc.Solver.Interact. - -In particular, `canEqCanLHSHetero` produces the following constraint equalities - -[X] (xi1 :: ki1) ~ (xi2 :: ki2) - --> [X] kco :: ki1 ~ ki2 - [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1 - -Note that the types in the LHS of the new constraints are the ones that were on the LHS of -the original constraint. - ---- Historical note --- -We prevously used to flip the kco to avoid using a sym in the cast - -[X] (xi1 :: ki1) ~ (xi2 :: ki2) - --> [X] kco :: ki2 ~ ki1 - [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1 - -But this sent solver in an infinite loop (see #19415). --- End of historical note -- --} - -canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) - -> EqRel -> SwapFlag - -> CanEqLHS -- xi1 - -> TcKind -- ki1 - -> TcType -- xi2 - -> TcKind -- ki2 - -> TcS (StopOrContinue Ct) -canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2 - -- See Note [Equalities with incompatible kinds] - -- See Note [Kind Equality Orientation] - -- NB: preserve left-to-right orientation!! - -- See Note [Fundeps with instances, and equality orientation] - -- wrinkle (W2) in GHC.Tc.Solver.Interact - = do { (kind_ev, kind_co) <- mk_kind_eq -- :: ki1 ~N ki2 - - ; let -- kind_co :: (ki1 :: *) ~N (ki2 :: *) (whether swapped or not) - lhs_redn = mkReflRedn role xi1 - rhs_redn = mkGReflRightRedn role xi2 (mkSymCo kind_co) - - -- See Note [Equalities with incompatible kinds], Wrinkle (1) - -- This will be ignored in rewriteEqEvidence if the work item is a Given - rewriters = rewriterSetFromCo kind_co - - ; traceTcS "Hetero equality gives rise to kind equality" - (ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) - ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - - ; emitWorkNC [type_ev] -- delay the type equality until after we've finished - -- the kind equality, which may unlock things - -- See Note [Equalities with incompatible kinds] - - ; canEqNC kind_ev NomEq ki1 ki2 } - where - mk_kind_eq :: TcS (CtEvidence, CoercionN) - mk_kind_eq = case ev of - CtGiven { ctev_evar = evar } - -> do { let kind_co = maybe_sym $ mkKindCo (mkCoVarCo evar) -- :: k1 ~ k2 - ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) - ; return (kind_ev, ctEvCoercion kind_ev) } - - CtWanted { ctev_rewriters = rewriters } - -> newWantedEq kind_loc rewriters Nominal ki1 ki2 - - xi1 = canEqLHSType lhs1 - loc = ctev_loc ev - role = eqRelRole eq_rel - kind_loc = mkKindLoc xi1 xi2 loc - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2 - - maybe_sym = case swapped of - IsSwapped -> mkSymCo -- if the input is swapped, then we - -- will have k2 ~ k1, so flip it to k1 ~ k2 - NotSwapped -> id - --- guaranteed that typeKind lhs == typeKind rhs -canEqCanLHSHomo :: CtEvidence - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- pretty lhs - -> TcType -> TcType -- rhs, pretty rhs - -> TcS (StopOrContinue Ct) -canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 - | (xi2', mco) <- split_cast_ty xi2 - , Just lhs2 <- canEqLHS_maybe xi2' - = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco - - | otherwise - = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 - - where - split_cast_ty (CastTy ty co) = (ty, MCo co) - split_cast_ty other = (other, MRefl) - --- This function deals with the case that both LHS and RHS are potential --- CanEqLHSs. -canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco) - -- or, if swapped: (rhs |> mco) ~ lhs - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- pretty lhs - -> CanEqLHS -- rhs - -> TcType -- pretty rhs - -> MCoercion -- :: kind(rhs) ~N kind(lhs) - -> TcS (StopOrContinue Ct) -canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco - | lhs1 `eqCanEqLHS` lhs2 - -- It must be the case that mco is reflexive - = canEqReflexive ev eq_rel (canEqLHSType lhs1) - - | TyVarLHS tv1 <- lhs1 - , TyVarLHS tv2 <- lhs2 - , swapOverTyVars (isGiven ev) tv1 tv2 - = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - ; new_ev <- do_swap - ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2) - (ps_xi1 `mkCastTyMCo` sym_mco) } - - | TyVarLHS tv1 <- lhs1 - , TyFamLHS fun_tc2 fun_args2 <- lhs2 - = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco - - | TyFamLHS fun_tc1 fun_args1 <- lhs1 - , TyVarLHS tv2 <- lhs2 - = do { new_ev <- do_swap - ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2 - fun_tc1 fun_args1 ps_xi1 sym_mco } - - | TyFamLHS fun_tc1 fun_args1 <- lhs1 - , TyFamLHS fun_tc2 fun_args2 <- lhs2 - -- See Note [Decomposing type family applications] - = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) - - -- emit wanted equalities for injective type families - ; let inj_eqns :: [TypeEqn] -- TypeEqn = Pair Type - inj_eqns - | ReprEq <- eq_rel = [] -- injectivity applies only for nom. eqs. - | fun_tc1 /= fun_tc2 = [] -- if the families don't match, stop. - - | Injective inj <- tyConInjectivityInfo fun_tc1 - = [ Pair arg1 arg2 - | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ] - - -- built-in synonym families don't have an entry point - -- for this use case. So, we just use sfInteractInert - -- and pass two equal RHSs. We *could* add another entry - -- point, but then there would be a burden to make - -- sure the new entry point and existing ones were - -- internally consistent. This is slightly distasteful, - -- but it works well in practice and localises the - -- problem. - | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1 - = let ki1 = canEqLHSKind lhs1 - ki2 | MRefl <- mco - = ki1 -- just a small optimisation - | otherwise - = canEqLHSKind lhs2 - - fake_rhs1 = anyTypeOfKind ki1 - fake_rhs2 = anyTypeOfKind ki2 - in - sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2 - - | otherwise -- ordinary, non-injective type family - = [] - - ; case ev of - CtWanted { ctev_rewriters = rewriters } -> - mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns - CtGiven {} -> return () - -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact - - ; tclvl <- getTcLevel - ; let tvs1 = tyCoVarsOfTypes fun_args1 - tvs2 = tyCoVarsOfTypes fun_args2 - - swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 && - -- swap 'em: Note [Put touchable variables on the left] - not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1) - -- this check is just to avoid unfruitful swapping - - -- If we have F a ~ F (F a), we want to swap. - swap_for_occurs - | cterHasNoProblem $ checkTyFamEq fun_tc2 fun_args2 - (mkTyConApp fun_tc1 fun_args1) - , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1 - (mkTyConApp fun_tc2 fun_args2) - = True - - | otherwise - = False - - ; if swap_for_rewriting || swap_for_occurs - then do { new_ev <- do_swap - ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } - else finish_without_swapping } - - -- that's all the special cases. Now we just figure out which non-special case - -- to continue to. - | otherwise - = finish_without_swapping - - where - sym_mco = mkSymMCo mco - - do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco - finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) - - --- This function handles the case where one side is a tyvar and the other is --- a type family application. Which to put on the left? --- If the tyvar is a touchable meta-tyvar, put it on the left, as this may --- be our only shot to unify. --- Otherwise, put the function on the left, because it's generally better to --- rewrite away function calls. This makes types smaller. And it seems necessary: --- [W] F alpha ~ alpha --- [W] F alpha ~ beta --- [W] G alpha beta ~ Int ( where we have type instance G a a = a ) --- If we end up with a stuck alpha ~ F alpha, we won't be able to solve this. --- Test case: indexed-types/should_compile/CEqCanOccursCheck -canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco) - -- or (rhs |> mco) ~ lhs if swapped - -> EqRel -> SwapFlag - -> TyVar -> TcType -- lhs (or if swapped rhs), pretty lhs - -> TyCon -> [Xi] -> TcType -- rhs (or if swapped lhs) fun and args, pretty rhs - -> MCoercion -- :: kind(rhs) ~N kind(lhs) - -> TcS (StopOrContinue Ct) -canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco - = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs - ; if | case is_touchable of { Untouchable -> False; _ -> True } - , cterHasNoProblem $ - checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily - -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs - - | otherwise - -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped - (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2) - mco - ; canEqCanLHSFinish new_ev eq_rel IsSwapped - (TyFamLHS fun_tc2 fun_args2) - (ps_xi1 `mkCastTyMCo` sym_mco) } } - where - sym_mco = mkSymMCo mco - rhs = ps_xi2 `mkCastTyMCo` mco - --- The RHS here is either not CanEqLHS, or it's one that we --- want to rewrite the LHS to (as per e.g. swapOverTyVars) -canEqCanLHSFinish :: CtEvidence - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- rhs (or, if swapped, lhs) - -> TcS (StopOrContinue Ct) -canEqCanLHSFinish ev eq_rel swapped lhs rhs --- RHS is fully rewritten, but with type synonyms --- preserved as much as possible --- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) --- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 - - = do { - -- this performs the swap if necessary - new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn role lhs_ty) - (mkReflRedn role rhs) - - -- by now, (TyEq:K) is already satisfied - ; massert (canEqLHSKind lhs `eqType` typeKind rhs) - - -- by now, (TyEq:N) is already satisfied (if applicable) - ; assertPprM ty_eq_N_OK $ - vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied" - , text "rhs:" <+> ppr rhs - ] - - -- guarantees (TyEq:OC), (TyEq:F) - -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...); this is #12593. - ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily - -- type families are OK here - -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite - - -- a ~R# b a is soluble if b later turns out to be Identity - result = case eq_rel of - NomEq -> result0 - ReprEq -> cterSetOccursCheckSoluble result0 - - reason = NonCanonicalReason result - - ; if cterHasNoProblem result - then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs) - ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs - , cc_rhs = rhs, cc_eq_rel = eq_rel }) } - - else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs - -- See Note [Type equality cycles]; - -- returning Nothing is the vastly common case - ; case m_stuff of - { Nothing -> - do { traceTcS "canEqCanLHSFinish can't make a canonical" - (ppr lhs $$ ppr rhs) - ; continueWith (mkIrredCt reason new_ev) } - ; Just rhs_redn@(Reduction _ new_rhs) -> - do { traceTcS "canEqCanLHSFinish breaking a cycle" $ - ppr lhs $$ ppr rhs - ; traceTcS "new RHS:" (ppr new_rhs) - - -- This check is Detail (1) in the Note - ; if cterHasOccursCheck (checkTypeEq lhs new_rhs) - - then do { traceTcS "Note [Type equality cycles] Detail (1)" - (ppr new_rhs) - ; continueWith (mkIrredCt reason new_ev) } - - else do { -- See Detail (6) of Note [Type equality cycles] - new_new_ev <- rewriteEqEvidence emptyRewriterSet - new_ev NotSwapped - (mkReflRedn Nominal lhs_ty) - rhs_redn - - ; continueWith (CEqCan { cc_ev = new_new_ev - , cc_lhs = lhs - , cc_rhs = new_rhs - , cc_eq_rel = eq_rel }) }}}}} - where - role = eqRelRole eq_rel - - lhs_ty = canEqLHSType lhs - - -- This is about (TyEq:N): check that we don't have a saturated application - -- of a newtype TyCon at the top level of the RHS, if the constructor - -- of the newtype is in scope. - ty_eq_N_OK :: TcS Bool - ty_eq_N_OK - | ReprEq <- eq_rel - , Just (tc, tc_args) <- splitTyConApp_maybe rhs - , Just con <- newTyConDataCon_maybe tc - -- #22310: only a problem if the newtype TyCon is saturated. - , tc_args `lengthAtLeast` tyConArity tc - -- #21010: only a problem if the newtype constructor is in scope. - = do { rdr_env <- getGlobalRdrEnvTcS - ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con) - ; return $ not con_in_scope } - | otherwise - = return True - --- | Solve a reflexive equality constraint -canEqReflexive :: CtEvidence -- ty ~ ty - -> EqRel - -> TcType -- ty - -> TcS (StopOrContinue Ct) -- always Stop -canEqReflexive ev eq_rel ty - = do { setEvBindIfWanted ev (evCoercion $ - mkReflCo (eqRelRole eq_rel) ty) - ; stopWith ev "Solved by reflexivity" } - -rewriteCastedEquality :: CtEvidence -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs - -> EqRel -> SwapFlag - -> TcType -- lhs - -> TcType -- rhs - -> MCoercion -- mco - -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs - -- result is independent of SwapFlag -rewriteCastedEquality ev eq_rel swapped lhs rhs mco - = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn - where - lhs_redn = mkGReflRightMRedn role lhs sym_mco - rhs_redn = mkGReflLeftMRedn role rhs mco - - sym_mco = mkSymMCo mco - role = eqRelRole eq_rel - -{- Note [Equalities with incompatible kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What do we do when we have an equality - - (tv :: k1) ~ (rhs :: k2) - -where k1 and k2 differ? Easy: we create a coercion that relates k1 and -k2 and use this to cast. To wit, from - - [X] (tv :: k1) ~ (rhs :: k2) - -(where [X] is [G] or [W]), we go to - - [X] co :: k1 ~ k2 - [X] (tv :: k1) ~ ((rhs |> sym co) :: k1) - -We carry on with the *kind equality*, not the type equality, because -solving the former may unlock the latter. This choice is made in -canEqCanLHSHetero. It is important: otherwise, T13135 loops. - -Wrinkles: - - (1) When X is W, the new type-level wanted is effectively rewritten by the - kind-level one. We thus include the kind-level wanted in the RewriterSet - for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. - This is done in canEqCanLHSHetero. - - (2) If we have [W] w :: alpha ~ (rhs |> sym co_hole), should we unify alpha? No. - The problem is that the wanted w is effectively rewritten by another wanted, - and unifying alpha effectively promotes this wanted to a given. Doing so - means we lose track of the rewriter set associated with the wanted. - - On the other hand, w is perfectly suitable for rewriting, because of the - way we carefully track rewriter sets. - - We thus allow w to be a CEqCan, but we prevent unification. See - Note [Unification preconditions] in GHC.Tc.Utils.Unify. - - The only tricky part is that we must later indeed unify if/when the kind-level - wanted gets solved. This is done in kickOutAfterFillingCoercionHole, - which kicks out all equalities whose RHS mentions the filled-in coercion hole. - Note that it looks for type family equalities, too, because of the use of - unifyTest in canEqTyVarFunEq. - - (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the - algorithm detailed here, producing [W] co :: k1 ~ k2, and adding - [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time - later, we solve co, and fill in co's coercion hole. This kicks out - the irreducible as described in (2). - But now, during canonicalization, we see the cast - and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality - is heterogeneous again, and the process repeats. - - To avoid this, we don't strip casts off a type if the other type - in the equality is a CanEqLHS (the scenario above can happen with a - type family, too. testcase: typecheck/should_compile/T13822). - And this is an improvement regardless: - because tyvars can, generally, unify with casted types, there's no - reason to go through the work of stripping off the cast when the - cast appears opposite a tyvar. This is implemented in the cast case - of can_eq_nc'. - -Historical note: - -We used to do this via emitting a Derived kind equality and then parking -the heterogeneous equality as irreducible. But this new approach is much -more direct. And it doesn't produce duplicate Deriveds (as the old one did). - -Note [Type synonyms and canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat type synonym applications as xi types, that is, they do not -count as type function applications. However, we do need to be a bit -careful with type synonyms: like type functions they may not be -generative or injective. However, unlike type functions, they are -parametric, so there is no problem in expanding them whenever we see -them, since we do not need to know anything about their arguments in -order to expand them; this is what justifies not having to treat them -as specially as type function applications. The thing that causes -some subtleties is that we prefer to leave type synonym applications -*unexpanded* whenever possible, in order to generate better error -messages. - -If we encounter an equality constraint with type synonym applications -on both sides, or a type synonym application on one side and some sort -of type application on the other, we simply must expand out the type -synonyms in order to continue decomposing the equality constraint into -primitive equality constraints. For example, suppose we have - - type F a = [Int] - -and we encounter the equality - - F a ~ [b] - -In order to continue we must expand F a into [Int], giving us the -equality - - [Int] ~ [b] - -which we can then decompose into the more primitive equality -constraint - - Int ~ b. - -However, if we encounter an equality constraint with a type synonym -application on one side and a variable on the other side, we should -NOT (necessarily) expand the type synonym, since for the purpose of -good error messages we want to leave type synonyms unexpanded as much -as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. - -Note [Type equality cycles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this situation (from indexed-types/should_compile/GivenLoop): - - instance C (Maybe b) - *[G] a ~ Maybe (F a) - [W] C a - -or (typecheck/should_compile/T19682b): - - instance C (a -> b) - *[W] alpha ~ (Arg alpha -> Res alpha) - [W] C alpha - -or (typecheck/should_compile/T21515): - - type family Code a - *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ] - [W] Code a ~ '[ '[ alpha ] ] - -In order to solve the final Wanted, we must use the starred constraint -for rewriting. But note that all starred constraints have occurs-check failures, -and so we can't straightforwardly add these to the inert set and -use them for rewriting. (NB: A rigid type constructor is at the -top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar -cases.) - -The key idea is to replace the outermost type family applications in the RHS of the -starred constraints with a fresh variable, which we'll call a cycle-breaker -variable, or cbv. Then, relate the cbv back with the original type family application -via new equality constraints. Our situations thus become: - - instance C (Maybe b) - [G] a ~ Maybe cbv - [G] F a ~ cbv - [W] C a - -or - - instance C (a -> b) - [W] alpha ~ (cbv1 -> cbv2) - [W] Arg alpha ~ cbv1 - [W] Res alpha ~ cbv2 - [W] C alpha - -or - - [G] Code a ~ '[ '[ cbv ] ] - [G] Head (Head (Code a)) ~ cbv - [W] Code a ~ '[ '[ alpha ] ] - -This transformation (creating the new types and emitting new equality -constraints) is done in breakTyEqCycle_maybe. - -The details depend on whether we're working with a Given or a Wanted. - -Given ------ - -We emit a new Given, [G] F a ~ cbv, equating the type family application to -our new cbv. Note its orientation: The type family ends up on the left; see -commentary on canEqTyVarFunEq, which decides how to orient such cases. No -special treatment for CycleBreakerTvs is necessary. This scenario is now -easily soluble, by using the first Given to rewrite the Wanted, which can now -be solved. - -(The first Given actually also rewrites the second one, giving -[G] F (Maybe cbv) ~ cbv, but this causes no trouble.) - -Of course, we don't want our fresh variables leaking into e.g. error messages. -So we fill in the metavariables with their original type family applications -after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds). -This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in -InertSet, which contains the pairings invented in breakTyEqCycle_maybe. - -That is: - -We transform - [G] g : lhs ~ ...(F lhs)... -to - [G] (Refl lhs) : F lhs ~ cbv -- CEqCan - [G] g : lhs ~ ...cbv... -- CEqCan - -Note that -* `cbv` is a fresh cycle breaker variable. -* `cbv` is a is a meta-tyvar, but it is completely untouchable. -* We track the cycle-breaker variables in inert_cycle_breakers in InertSet -* We eventually fill in the cycle-breakers, with `cbv := F lhs`. - No one else fills in cycle-breakers! -* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know - this fill-in is ultimately going to happen. -* In inert_cycle_breakers, we remember the (cbv, F lhs) pair; that is, we - remember the /original/ type. The [G] F lhs ~ cbv constraint may be rewritten - by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we - still fill in with cbv := F lhs -* This fill-in is done when solving is complete, by restoreTyVarCycles - in nestImplicTcS and runTcSWithEvBinds. - -Wanted ------- -The fresh cycle-breaker variables here must actually be normal, touchable -metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating -the example from above, we have - - *[W] alpha ~ (Arg alpha -> Res alpha) - -and we turn this into - - *[W] alpha ~ (cbv1 -> cbv2) - [W] Arg alpha ~ cbv1 - [W] Res alpha ~ cbv2 - -where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. - -Critically, we emit the two new constraints (the last two above) -directly instead of calling unifyWanted. (Otherwise, we'd end up unifying cbv1 -and cbv2 immediately, achieving nothing.) -Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This -unification -- which must be the next step after breaking the cycles -- -happens in the course of normal behavior of top-level -interactions, later in the solver pipeline. We know this unification will -indeed happen because breakTyEqCycle_maybe, which decides whether to apply -this logic, checks to ensure unification will succeed in its final_check. -(In particular, the LHS must be a touchable tyvar, never a type family. We don't -yet have an example of where this logic is needed with a type family, and it's -unclear how to handle this case, so we're skipping for now.) Now, we're -here (including further context from our original example, from the top of the -Note): - - instance C (a -> b) - [W] Arg (cbv1 -> cbv2) ~ cbv1 - [W] Res (cbv1 -> cbv2) ~ cbv2 - [W] C (cbv1 -> cbv2) - -The first two W constraints reduce to reflexivity and are discarded, -and the last is easily soluble. - -[Why TauTvs]: -Let's look at another example (typecheck/should_compile/T19682) where we need -to unify the cbvs: - - class (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys - instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys - - type family SameShapeAs xs ys :: Constraint where - SameShapeAs '[] ys = (ys ~ '[]) - SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys)) - - type family AllEqF xs ys :: Constraint where - AllEqF '[] '[] = () - AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) - - [W] alpha ~ (Head alpha : Tail alpha) - [W] AllEqF '[Bool] alpha - -Without the logic detailed in this Note, we're stuck here, as AllEqF cannot -reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, -just as described above. We thus invent cbv1 and cbv2 and unify -alpha := cbv1 -> cbv2, yielding (after zonking) - - [W] Head (cbv1 : cbv2) ~ cbv1 - [W] Tail (cbv1 : cbv2) ~ cbv2 - [W] AllEqF '[Bool] (cbv1 : cbv2) - -The first two W constraints simplify to reflexivity and are discarded. -But the last reduces: - - [W] Bool ~ cbv1 - [W] AllEq '[] cbv2 - -The first of these is solved by unification: cbv1 := Bool. The second -is solved by the instance for AllEq to become - - [W] AllEqF '[] cbv2 - [W] SameShapeAs '[] cbv2 - -While the first of these is stuck, the second makes progress, to lead to - - [W] AllEqF '[] cbv2 - [W] cbv2 ~ '[] - -This second constraint is solved by unification: cbv2 := '[]. We now -have - - [W] AllEqF '[] '[] - -which reduces to - - [W] () - -which is trivially satisfiable. Hooray! - -Note that we need to unify the cbvs here; if we did not, there would be -no way to solve those constraints. That's why the cycle-breakers are -ordinary TauTvs. - -In all cases ------------- - -We detect this scenario by the following characteristics: - - a constraint with a soluble occurs-check failure - (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult - from checkTypeEq) - - and a nominal equality - - and either - - a Given flavour (but see also Detail (7) below) - - a Wanted flavour, with a touchable metavariable on the left - -We don't use this trick for representational equalities, as there is no -concrete use case where it is helpful (unlike for nominal equalities). -Furthermore, because function applications can be CanEqLHSs, but newtype -applications cannot, the disparities between the cases are enough that it -would be effortful to expand the idea to representational equalities. A quick -attempt, with - - data family N a b - - f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b - f = coerce - -failed with "Could not match 'b' with 'b'." Further work is held off -until when we have a concrete incentive to explore this dark corner. - -Details: - - (1) We don't look under foralls, at all, when substituting away type family - applications, because doing so can never be fruitful. Recall that we - are in a case like [G] lhs ~ forall b. ... lhs .... Until we have a type - family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty), - this will always be - insoluble. Note also that the forall cannot be in an argument to a - type family, or that outer type family application would already have - been substituted away. - - However, we still must check to make sure that breakTyEqCycle_maybe actually - succeeds in getting rid of all occurrences of the offending lhs. If - one is hidden under a forall, this won't be true. A similar problem can - happen if the variable appears only in a kind - (e.g. k ~ ... (a :: k) ...). So we perform an additional check after - performing the substitution. It is tiresome to re-run all of checkTypeEq - here, but reimplementing just the occurs-check is even more tiresome. - - Skipping this check causes typecheck/should_fail/GivenForallLoop and - polykinds/T18451 to loop. - - (2) Our goal here is to avoid loops in rewriting. We can thus skip looking - in coercions, as we don't rewrite in coercions in the algorithm in - GHC.Solver.Rewrite. (This is another reason - we need to re-check that we've gotten rid of all occurrences of the - offending variable.) - - (3) As we're substituting as described in this Note, we can build ill-kinded - types. For example, if we have Proxy (F a) b, where (b :: F a), then - replacing this with Proxy cbv b is ill-kinded. However, we will later - set cbv := F a, and so the zonked type will be well-kinded again. - The temporary ill-kinded type hurts no one, and avoiding this would - be quite painfully difficult. - - Specifically, this detail does not contravene the Purely Kinded Type Invariant - (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType). - The PKTI says that we can call typeKind on any type, without failure. - It would be violated if we, say, replaced a kind (a -> b) with a kind c, - because an arrow kind might be consulted in piResultTys. Here, we are - replacing one opaque type like (F a b c) with another, cbv (opaque in - that we never assume anything about its structure, like that it has a - result type or a RuntimeRep argument). - - (4) The evidence for the produced Givens is all just reflexive, because - we will eventually set the cycle-breaker variable to be the type family, - and then, after the zonk, all will be well. See also the notes at the - end of the Given section of this Note. - - (5) The approach here is inefficient because it replaces every (outermost) - type family application with a type variable, regardless of whether that - particular appplication is implicated in the occurs check. An alternative - would be to replce only type-family applications that mention the offending LHS. - For instance, we could choose to - affect only type family applications that mention the offending LHS: - e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore, - we could try to detect cases like a ~ (F a, F a) and use the same - tyvar to replace F a. (Cf. - Note [Flattening type-family applications when matching instances] - in GHC.Core.Unify, which - goes to this extra effort.) There may be other opportunities for - improvement. However, this is really a very small corner case. - The investment to craft a clever, - performant solution seems unworthwhile. - - (6) We often get the predicate associated with a constraint from its - evidence with ctPred. We thus must not only make sure the generated - CEqCan's fields have the updated RHS type (that is, the one produced - by replacing type family applications with fresh variables), - but we must also update the evidence itself. This is done by the call to rewriteEqEvidence - in canEqCanLHSFinish. - - (7) We don't wish to apply this magic on the equalities created - by this very same process. - Consider this, from typecheck/should_compile/ContextStack2: - - type instance TF (a, b) = (TF a, TF b) - t :: (a ~ TF (a, Int)) => ... - - [G] a ~ TF (a, Int) - - The RHS reduces, so we get - - [G] a ~ (TF a, TF Int) - - We then break cycles, to get - - [G] g1 :: a ~ (cbv1, cbv2) - [G] g2 :: TF a ~ cbv1 - [G] g3 :: TF Int ~ cbv2 - - g1 gets added to the inert set, as written. But then g2 becomes - the work item. g1 rewrites g2 to become - - [G] TF (cbv1, cbv2) ~ cbv1 - - which then uses the type instance to become - - [G] (TF cbv1, TF cbv2) ~ cbv1 - - which looks remarkably like the Given we started with. If left - unchecked, this will end up breaking cycles again, looping ad - infinitum (and resulting in a context-stack reduction error, - not an outright loop). The solution is easy: don't break cycles - on an equality generated by breaking cycles. Instead, we mark this - final Given as a CIrredCan with a NonCanonicalReason with the soluble - occurs-check bit set (only). - - We track these equalities by giving them a special CtOrigin, - CycleBreakerOrigin. This works for both Givens and Wanteds, as - we need the logic in the W case for e.g. typecheck/should_fail/T17139. - Because this logic needs to work for Wanteds, too, we cannot - simply look for a CycleBreakerTv on the left: Wanteds don't use them. - - (8) We really want to do this all only when there is a soluble occurs-check - failure, not when other problems arise (such as an impredicative - equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe - uses cterHasOnlyProblem when looking at the result of checkTypeEq, which - checks for many of the invariants on a CEqCan. --} - -{- -************************************************************************ -* * - Evidence transformation -* * -************************************************************************ --} - -data StopOrContinue a - = ContinueWith a -- The constraint was not solved, although it may have - -- been rewritten - - | Stop CtEvidence -- The (rewritten) constraint was solved - SDoc -- Tells how it was solved - -- Any new sub-goals have been put on the work list - deriving (Functor) - -instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev - ppr (ContinueWith w) = text "ContinueWith" <+> ppr w - -continueWith :: a -> TcS (StopOrContinue a) -continueWith = return . ContinueWith - -stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) -stopWith ev s = return (Stop ev (text s)) - -andWhenContinue :: TcS (StopOrContinue a) - -> (a -> TcS (StopOrContinue b)) - -> TcS (StopOrContinue b) -andWhenContinue tcs1 tcs2 - = do { r <- tcs1 - ; case r of - Stop ev s -> return (Stop ev s) - ContinueWith ct -> tcs2 ct } -infixr 0 `andWhenContinue` -- allow chaining with ($) - -rewriteEvidence :: RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] - -- in GHC.Tc.Types.Constraint - -> CtEvidence -- ^ old evidence - -> Reduction -- ^ new predicate + coercion, of type ~ new predicate - -> TcS (StopOrContinue CtEvidence) --- Returns Just new_ev iff either (i) 'co' is reflexivity --- or (ii) 'co' is not reflexivity, and 'new_pred' not cached --- In either case, there is nothing new to do with new_ev -{- - rewriteEvidence old_ev new_pred co -Main purpose: create new evidence for new_pred; - unless new_pred is cached already -* Returns a new_ev : new_pred, with same wanted/given flag as old_ev -* If old_ev was wanted, create a binding for old_ev, in terms of new_ev -* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev -* Returns Nothing if new_ev is already cached - - Old evidence New predicate is Return new evidence - flavour of same flavor - ------------------------------------------------------------------- - Wanted Already solved or in inert Nothing - Not Just new_evidence - - Given Already in inert Nothing - Not Just new_evidence - -Note [Rewriting with Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the coercion is just reflexivity then you may re-use the same -variable. But be careful! Although the coercion is Refl, new_pred -may reflect the result of unification alpha := ty, so new_pred might -not _look_ the same as old_pred, and it's vital to proceed from now on -using new_pred. - -The rewriter preserves type synonyms, so they should appear in new_pred -as well as in old_pred; that is important for good error messages. - -If we are rewriting with Refl, then there are no new rewriters to add to -the rewriter set. We check this with an assertion. - -} - - -rewriteEvidence rewriters old_ev (Reduction co new_pred) - | isReflCo co -- See Note [Rewriting with Refl] - = assert (isEmptyRewriterSet rewriters) $ - continueWith (setCtEvPredType old_ev new_pred) - -rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) - (Reduction co new_pred) - = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted - do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; continueWith new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (evId old_evar) - (downgradeRole Representational (ctEvRole ev) co) - -rewriteEvidence new_rewriters - ev@(CtWanted { ctev_dest = dest - , ctev_loc = loc - , ctev_rewriters = rewriters }) - (Reduction co new_pred) - = do { mb_new_ev <- newWanted loc rewriters' new_pred - ; massert (coercionRole co == ctEvRole ev) - ; setWantedEvTerm dest - (mkEvCast (getEvExpr mb_new_ev) - (downgradeRole Representational (ctEvRole ev) (mkSymCo co))) - ; case mb_new_ev of - Fresh new_ev -> continueWith new_ev - Cached _ -> stopWith ev "Cached wanted" } - where - rewriters' = rewriters S.<> new_rewriters - - -rewriteEqEvidence :: RewriterSet -- New rewriters - -- See GHC.Tc.Types.Constraint - -- Note [Wanteds rewrite Wanteds] - -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) - -- or orhs ~ olhs (swapped) - -> SwapFlag - -> Reduction -- lhs_co :: olhs ~ nlhs - -> Reduction -- rhs_co :: orhs ~ nrhs - -> TcS CtEvidence -- Of type nlhs ~ nrhs --- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs), --- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): --- If not swapped --- g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co --- If swapped --- g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co --- --- For a wanted equality (Wanted w), we do the dual thing: --- New w1 : nlhs ~ nrhs --- If not swapped --- w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co --- If swapped --- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co --- --- It's all a form of rewriteEvidence, specialised for equalities -rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) - | NotSwapped <- swapped - , isReflCo lhs_co -- See Note [Rewriting with Refl] - , isReflCo rhs_co - = return (setCtEvPredType old_ev new_pred) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion ( mkSymCo lhs_co - `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar) - `mkTransCo` rhs_co) - ; newGivenEvVar loc (new_pred, new_tm) } - - | CtWanted { ctev_dest = dest - , ctev_rewriters = rewriters } <- old_ev - , let rewriters' = rewriters S.<> new_rewriters - = do { (new_ev, hole_co) <- newWantedEq loc rewriters' - (ctEvRole old_ev) nlhs nrhs - ; let co = maybeSymCo swapped $ - lhs_co - `mkTransCo` hole_co - `mkTransCo` mkSymCo rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev - , ppr nlhs - , ppr nrhs - , ppr co - , ppr new_rewriters ]) - ; return new_ev } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "rewriteEvidence" -#endif - where - new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs - loc = ctEvLoc old_ev - -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [unifyWanted] -~~~~~~~~~~~~~~~~~~ -When decomposing equalities we often create new wanted constraints for -(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. - -Rather than making an equality test (which traverses the structure of the -type, perhaps fruitlessly), unifyWanted traverses the common structure, and -bales out when it finds a difference by creating a new Wanted constraint. -But where it succeeds in finding common structure, it just builds a coercion -to reflect it. --} - -unifyWanted :: RewriterSet -> CtLoc - -> Role -> TcType -> TcType -> TcS Coercion --- Return coercion witnessing the equality of the two types, --- emitting new work equalities where necessary to achieve that --- Very good short-cut when the two types are equal, or nearly so --- See Note [unifyWanted] --- The returned coercion's role matches the input parameter -unifyWanted rewriters loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted rewriters loc Nominal (typeKind ty1) (typeKind ty2) - ; return (mkPhantomCo kind_co ty1 ty2) } - -unifyWanted rewriters loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - - go (FunTy af1 w1 s1 t1) (FunTy af2 w2 s2 t2) - | af1 == af2 -- Important! See #21530 - = do { co_s <- unifyWanted rewriters loc role s1 s2 - ; co_t <- unifyWanted rewriters loc role t1 t2 - ; co_w <- unifyWanted rewriters loc Nominal w1 w2 - ; return (mkNakedFunCo1 role af1 co_w co_s co_t) } - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = do { cos <- zipWith3M (unifyWanted rewriters loc) - (tyConRoleListX role tc1) tys1 tys2 - ; return (mkTyConAppCo role tc1 cos) } - - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2} - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - - go ty1@(CoercionTy {}) (CoercionTy {}) - = return (mkReflCo role ty1) -- we just don't care about coercions! - - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2 - - -{- -Note [Decomposing Dependent TyCons and Processing Wanted Equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we decompose a dependent tycon we obtain a list of -mixed wanted type and kind equalities. Ideally we want -all the kind equalities to get solved first so that we avoid -generating duplicate kind equalities - -For example, consider decomposing a TyCon equality - - (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k_fresh) - -This gives rise to 2 equalities in the solver worklist - - (1) [W] k_fresh ~ k1 - (2) [W] t1::k_fresh ~ t2::k1 - -The solver worklist is processed in LIFO order: -see GHC.Tc.Solver.InertSet.selectWorkItem. -i.e. (2) is processed _before_ (1). Now, while solving (2) -we would call `canEqCanLHSHetero` and that would emit a -wanted kind equality - - (3) [W] k_fresh ~ k1 - -But (3) is exactly the same as (1)! - -To avoid such duplicate wanted constraints from being added to the worklist, -we ensure that (2) is processed before (1). Since we are processing -the worklist in a LIFO ordering, we do it by emitting (1) before (2). -This is exactly what we do in `unifyWanteds`. - -NB: This ordering is not needed when we decompose FunTyCons as they are not dependently typed --} - --- NB: Length of [CtLoc] and [Roles] may be infinite --- but list of RHS [TcType] and LHS [TcType] is finite and both are of equal length -unifyWanteds :: RewriterSet -> [CtLoc] -> [Role] - -> [TcType] -- List of RHS types - -> [TcType] -- List of LHS types - -> TcS [Coercion] -unifyWanteds rewriters ctlocs roles rhss lhss = unify_wanteds rewriters $ zip4 ctlocs roles rhss lhss - where - -- Order is important here - -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities] - unify_wanteds _ [] = return [] - unify_wanteds rewriters ((new_loc, tc_role, ty1, ty2) : rest) - = do { cos <- unify_wanteds rewriters rest - ; co <- unifyWanted rewriters new_loc tc_role ty1 ty2 - ; return (co:cos) } diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Dict.hs @@ -0,0 +1,2177 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | Solving Class constraints CDictCan +module GHC.Tc.Solver.Dict ( + solveDict, solveDictNC, + checkInstanceOK, + matchLocalInst, chooseInstance, + makeSuperClasses, mkStrictSuperClasses, + solveCallStack -- For GHC.Tc.Solver + ) where + +import GHC.Prelude + +import GHC.Tc.Errors.Types +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Class( safeOverlap, matchEqualityInst ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Types.EvTerm( evCallStack ) +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad +import GHC.Tc.Solver.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify( uType ) + +import GHC.Hs.Type( HsIPName(..) ) + +import GHC.Core +import GHC.Core.Type +import GHC.Core.InstEnv ( DFunInstType ) +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.Unify ( ruleMatchTyKiX ) + +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Id( mkTemplateLocals ) +import GHC.Types.Var.Set +import GHC.Types.SrcLoc +import GHC.Types.Var.Env + +import GHC.Utils.Monad ( concatMapM, foldlM ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Data.Bag + +import GHC.Driver.DynFlags + +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( listToMaybe, mapMaybe, isJust ) +import Data.Void( Void ) + +import Control.Monad.Trans.Maybe( MaybeT, runMaybeT ) +import Control.Monad.Trans.Class( lift ) +import Control.Monad( mzero ) + + +{- ********************************************************************* +* * +* Class Canonicalization +* * +********************************************************************* -} + +solveDictNC :: CtEvidence -> Class -> [Type] -> SolverStage Void +-- NC: this comes from CNonCanonical or CIrredCan +-- Precondition: already rewritten by inert set +solveDictNC ev cls tys + = do { simpleStage $ traceTcS "solveDictNC" (ppr (mkClassPred cls tys) $$ ppr ev) + ; dict_ct <- canDictCt ev cls tys + ; solveDict dict_ct } + +solveDict :: DictCt -> SolverStage Void +-- Preconditions: `tys` are already rewritten by the inert set +solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) + | isEqualityClass cls + = solveEqualityDict ev cls tys + + | otherwise + = assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ + do { simpleStage $ traceTcS "solveDict" (ppr dict_ct) + + ; tryInertDicts dict_ct + ; tryInstances dict_ct + + -- Try fundeps /after/ tryInstances: + -- see (DFL2) in Note [Do fundeps last] + ; doLocalFunDepImprovement dict_ct + -- doLocalFunDepImprovement does StartAgain if there + -- are any fundeps: see (DFL1) in Note [Do fundeps last] + + ; doTopFunDepImprovement dict_ct + + ; tryLastResortProhibitedSuperClass dict_ct + ; simpleStage (updInertDicts dict_ct) + ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } + +updInertDicts :: DictCt -> TcS () +updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) + = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) + + ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys + -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] + -- Update /both/ inert_cans /and/ inert_solved_dicts. + updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> + inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics + , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved } + | otherwise + -> return () + + -- Add the new constraint to the inert set + ; updInertCans (updDicts (addDict dict_ct)) } + where + not_ip_for :: Type -> DictCt -> Bool + not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) + = not (mentionsIP str_ty cls tys) + +canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt +-- Once-only processing of Dict constraints: +-- * expand superclasses +-- * deal with CallStack +canDictCt ev cls tys + | isGiven ev -- See Note [Eagerly expand given superclasses] + = Stage $ + do { dflags <- getDynFlags + ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev [] [] cls tys + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + ; emitWork (listToBag sc_cts) + + ; continueWith (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand }) } + -- doNotExpand: We have already expanded superclasses for /this/ dict + -- so set the fuel to doNotExpand to avoid repeating expansion + + | CtWanted { ctev_rewriters = rewriters } <- ev + , Just ip_name <- isCallStackPred cls tys + , isPushCallStackOrigin orig + -- If we're given a CallStack constraint that arose from a function + -- call, we need to push the current call-site onto the stack instead + -- of solving it directly from a given. + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types + = Stage $ + do { -- First we emit a new constraint that will capture the + -- given CallStack. + let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) + -- We change the origin to IPOccOrigin so + -- this rule does not fire again. + -- See Note [Overview of implicit CallStacks] + -- in GHC.Tc.Types.Evidence + + ; new_ev <- newWantedEvVarNC new_loc rewriters pred + + -- Then we solve the wanted by pushing the call-site + -- onto the newly emitted CallStack + ; let ev_cs = EvCsPushCall (callStackOriginFS orig) + (ctLocSpan loc) (ctEvExpr new_ev) + ; solveCallStack ev ev_cs + + ; continueWith (DictCt { di_ev = new_ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand }) } + -- doNotExpand: No superclasses for class CallStack + -- See invariants in CDictCan.cc_pend_sc + + | otherwise + = Stage $ + do { dflags <- getDynFlags + ; let fuel | classHasSCs cls = wantedsFuel dflags + | otherwise = doNotExpand + -- See Invariants in `CCDictCan.cc_pend_sc` + ; continueWith (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = fuel }) } + where + loc = ctEvLoc ev + orig = ctLocOrigin loc + pred = ctEvPred ev + +solveCallStack :: CtEvidence -> EvCallStack -> TcS () +-- Also called from GHC.Tc.Solver when defaulting call stacks +solveCallStack ev ev_cs + -- We're given ev_cs :: CallStack, but the evidence term should be a + -- dictionary, so we have to coerce ev_cs to a dictionary for + -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] + = do { cs_tm <- evCallStack ev_cs + ; let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) + ; setEvBindIfWanted ev True ev_tm } + + +{- Note [Shadowing of implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we add a new /given/ implicit parameter to the inert set, it /replaces/ +any existing givens for the same implicit parameter. This makes a difference +in two places: + +* In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have + (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. + +* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any + existing [G] (?x :: ty'), regardless of ty'. + +* Wrinkle (SIP1): we must be careful of superclasses. Consider + f,g :: (?x::Int, C a) => a -> a + f v = let ?x = 4 in g v + + The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). + We must /not/ solve this from the Given (?x::Int, C a), because of + the intervening binding for (?x::Int). #14218. + + We deal with this by arranging that when we add [G] (?x::ty) we delete + * from the inert_cans, and + * from the inert_solved_dicts + any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass + with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate. + + An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). + But it could happen for `class xx => D xx where ...` and the constraint D + (?x :: int). This corner (constraint-kinded variables instantiated with + implicit parameter constraints) is not well explorered. + + Example in #14218, and #23761 + + The code that accounts for (SIP1) is in updInertDicts; in particular the call to + GHC.Core.Predicate.mentionsIP. + +* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts` + as well as `inert_cans`. + You might think that wouldn't be necessary, because an element of + `inert_solved_dicts` is never an implicit parameter (see + Note [Solved dictionaries] in GHC.Tc.Solver.InertSet). + While that is true, dictionaries in `inert_solved_dicts` may still have + implicit parameters as a /superclass/! For example: + + class c => C c where ... + f :: C (?x::Int) => blah + + Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it + happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`. + +Example 1: + +Suppose we have (typecheck/should_compile/ImplicitParamFDs) + flub :: (?x :: Int) => (Int, Integer) + flub = (?x, let ?x = 5 in ?x) +When we are checking the last ?x occurrence, we guess its type to be a fresh +unification variable alpha and emit an (IP "x" alpha) constraint. But the given +(?x :: Int) has been translated to an IP "x" Int constraint, which has a +functional dependency from the name to the type. So if that (?x::Int) is still +in the inert set, we'd get a fundep interaction that tells us that alpha ~ Int, +and we get a type error. This is bad. The "replacement" semantics stops this +happening. + +Example 2: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in two incompatible +ways: either by using the parameter from the signature, or by using the local +definition. Our intention is that the local definition should "shadow" the +parameter of the signature. The "replacement" semantics for implicit parameters +does this. + +Example 3: + +Similarly, consider + f :: (?x::a) => Bool -> a + + g v = let ?x::Int = 3 + in (f v, let ?x::Bool = True in f v) + +This should probably be well typed, with + g :: Bool -> (Int, Bool) + +So the inner binding for ?x::Bool *overrides* the outer one. + +See ticket #17104 for a rather tricky example of this overriding +behaviour. + +All this works for the normal cases but it has an odd side effect in +some pathological programs like this: + + -- This is accepted, the second parameter shadows + f1 :: (?x :: Int, ?x :: Char) => Char + f1 = ?x + + -- This is rejected, the second parameter shadows + f2 :: (?x :: Int, ?x :: Char) => Int + f2 = ?x + +Both of these are actually wrong: when we try to use either one, +we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), +which would lead to an error. + +I can think of two ways to fix this: + + 1. Simply disallow multiple constraints for the same implicit + parameter---this is never useful, and it can be detected completely + syntactically. + + 2. Move the shadowing machinery to the location where we nest + implications, and add some code here that will produce an + error if we get multiple givens for the same implicit parameter. +-} + + +{- ****************************************************************************** +* * + solveEqualityDict +* * +****************************************************************************** -} + +{- Note [Solving equality classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (~), which behaves as if it was defined like this: + class a ~# b => a ~ b + instance a ~# b => a ~ b +There are two more similar "equality classes" like this. The full list is + * (~) eqTyCon + * (~~) heqTyCon + * Coercible coercibleTyCon +(See Note [The equality types story] in GHC.Builtin.Types.Prim.) + +(EQC1) For Givens, when expanding the superclasses of a equality class, + we can /replace/ the constraint with its superclasses (which, remember, are + equally powerful) rather than /adding/ them. This can make a huge difference. + Consider T17836, which has a constraint like + forall b,c. a ~ (b,c) => + forall d,e. c ~ (d,e) => + ...etc... + If we just /add/ the superclasses of [G] g1:a ~ (b,c), we'll put + [G] g1:(a~(b,c)) in the inert set and emit [G] g2:a ~# (b,c). That will + kick out g1, and it'll be re-inserted as [G] g1':(b,c)~(b,c) which does + no good to anyone. When the implication is deeply nested, this has + quadratic cost, and no benefit. Just replace! + + (This can have a /big/ effect: test T17836 involves deeply-nested GADT + pattern matching. Its compile-time allocation decreased by 40% when + I added the "replace" rather than "add" semantics.) + +(EQC2) Faced with [W] t1 ~ t2, it's always OK to reduce it to [W] t1 ~# t2, + without worrying about Note [Instance and Given overlap]. Why? Because + if we had [G] s1 ~ s2, then we'd get the superclass [G] s1 ~# s2, and + so the reduction of the [W] constraint does not risk losing any solutions. + + On the other hand, it can be fatal to /fail/ to reduce such equalities + on the grounds of Note [Instance and Given overlap], because many good + things flow from [W] t1 ~# t2. + +Conclusion: we have a special solver pipeline for equality-class constraints, +`solveEqualityDict`. It aggressively decomposes the boxed equality constraint +into an unboxed coercion, both for Givens and Wanteds, and /replaces/ the +boxed equality constraint with the unboxed one, so that the inert set never +contains the boxed one. + +Note [Solving tuple constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I tried treating tuple constraints, such as (% Eq a, Show a %), rather like +equality-class constraints (see Note [Solving equality classes]). That is, by +eagerly decomposing tuple-constraints into their component (Eq a) and (Show a). + +But discarding the tuple Given (which "replacing" does) means that we may +have to reconstruct it for a recursive call. For example + f :: (% Eq a, Show a %) => blah + f x = ....(f x').... +If we decomposed eagerly we'd get + f = \(d : (% Eq a, Show a %)). + let de = fst d + ds = snd d + in ....(f (% de, ds %))... +and the optimiser may not be clever enough to transform (f (% de, ds %)) into +(f d). See #10359 and its test case, and #23398. (This issue is less pressing for +equality classes because they have to be unpacked strictly, so CSE-ing away +the reconstruction works fine. + +So at the moment we don't decompose tuple constraints eagerly; instead we mostly +just treat them like other constraints. +* Given tuples are decomposed via their superclasses, in `canDictCt`. So + [G] (% Eq a, Show a %) + has superclasses + [G] Eq a, [G] Show a + +* Wanted tuples are decomposed via a built-in "instance". See + `GHC.Tc.Instance.Class.matchCTuple` + +There is a bit of special treatment: search for isCTupleClass. +-} + +solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void +-- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible +solveEqualityDict ev cls tys + | CtWanted { ctev_dest = dest } <- ev + = Stage $ + do { let (data_con, role, t1, t2) = matchEqualityInst cls tys + -- Unify t1~t2, putting anything that can't be solved + -- immediately into the work list + ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> + uType uenv t1 t2 + -- Set d :: (t1~t2) = Eq# co + ; setWantedEvTerm dest True $ + evDataConApp data_con tys [Coercion co] + ; stopWith ev "Solved wanted lifted equality" } + + | CtGiven { ctev_evar = ev_id, ctev_loc = loc } <- ev + , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass + = Stage $ + do { let sc_pred = classMethodInstTy sel_id tys + ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id + ; given_ev <- newGivenEvVar loc (sc_pred, ev_expr) + ; startAgainWith (mkNonCanonical given_ev) } + | otherwise + = pprPanic "solveEqualityDict" (ppr cls) + +{- ****************************************************************************** +* * + interactDict +* * +********************************************************************************* + +Note [Shortcut solving] +~~~~~~~~~~~~~~~~~~~~~~~ +When we interact a [W] constraint with a [G] constraint that solves it, there is +a possibility that we could produce better code if instead we solved from a +top-level instance declaration (See #12791, #5835). For example: + + class M a b where m :: a -> b + + type C a b = (Num a, M a b) + + f :: C Int b => b -> Int -> Int + f _ x = x + 1 + +The body of `f` requires a [W] `Num Int` instance. We could solve this +constraint from the givens because we have `C Int b` and that provides us a +solution for `Num Int`. This would let us produce core like the following +(with -O2): + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> + + @ Int + (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) + eta1 + A.f1 + +This is bad! We could do /much/ better if we solved [W] `Num Int` directly +from the instance that we have in scope: + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) _ _ (x :: Int) -> + case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } + +** NB: It is important to emphasize that all this is purely an optimization: +** exactly the same programs should typecheck with or without this +** procedure. + +Solving fully +~~~~~~~~~~~~~ +There is a reason why the solver does not simply try to solve such +constraints with top-level instances. If the solver finds a relevant +instance declaration in scope, that instance may require a context +that can't be solved for. A good example of this is: + + f :: Ord [a] => ... + f x = ..Need Eq [a]... + +If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would +be left with the obligation to solve the constraint Eq a, which we cannot. So we +must be conservative in our attempt to use an instance declaration to solve the +[W] constraint we're interested in. + +Our rule is that we try to solve all of the instance's subgoals +recursively all at once. Precisely: We only attempt to solve +constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci +are themselves class constraints of the form `C1', ... Cm' => C' t1' +... tn'` and we only succeed if the entire tree of constraints is +solvable from instances. + +An example that succeeds: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [Int] b => b -> Bool + f x = m x == [] + +We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This +produces the following core: + + f :: forall b. C [Int] b => b -> Bool + f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> + GHC.Classes.$fEq[]_$s$c== + (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) + +An example that fails: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [a] b => b -> Bool + f x = m x == [] + +Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: + + f :: forall a b. C [a] b => b -> Bool + f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> + == + @ [a] + (A.$p1C @ [a] @ b $dC) + (m @ [a] @ b $dC eta) + (GHC.Types.[] @ a) + +Note [Shortcut solving: type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#13943) + class Take (n :: Nat) where ... + instance {-# OVERLAPPING #-} Take 0 where .. + instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. + +And we have [W] Take 3. That only matches one instance so we get +[W] Take (3-1). Really we should now rewrite to reduce the (3-1) to 2, and +so on -- but that is reproducing yet more of the solver. Sigh. For now, +we just give up (remember all this is just an optimisation). + +But we must not just naively try to lookup (Take (3-1)) in the +InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a +unique match on the (Take n) instance. That leads immediately to an +infinite loop. Hence the check that 'preds' have no type families +(isTyFamFree). + +Note [Shortcut solving: incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This optimization relies on coherence of dictionaries to be correct. When we +cannot assume coherence because of IncoherentInstances then this optimization +can change the behavior of the user's code. + +The following four modules produce a program whose output would change depending +on whether we apply this optimization when IncoherentInstances is in effect: + +========= + {-# LANGUAGE MultiParamTypeClasses #-} + module A where + + class A a where + int :: a -> Int + + class A a => C a b where + m :: b -> a -> a + +========= + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE MultiParamTypeClasses #-} + module B where + + import A + + instance A a where + int _ = 1 + + instance C a [b] where + m _ = id + +========= + {-# LANGUAGE FlexibleContexts #-} + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE IncoherentInstances #-} + {-# LANGUAGE MultiParamTypeClasses #-} + module C where + + import A + + instance A Int where + int _ = 2 + + instance C Int [Int] where + m _ = id + + intC :: C Int a => a -> Int -> Int + intC _ x = int x + +========= + module Main where + + import A + import B + import C + + main :: IO () + main = print (intC [] (0::Int)) + +The output of `main` if we avoid the optimization under the effect of +IncoherentInstances is `1`. If we were to do the optimization, the output of +`main` would be `2`. + +Note [Shortcut try_solve_from_instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The workhorse of the short-cut solver is + try_solve_from_instance :: (EvBindMap, DictMap CtEvidence) + -> CtEvidence -- Solve this + -> MaybeT TcS (EvBindMap, DictMap CtEvidence) +Note that: + +* The CtEvidence is the goal to be solved + +* The MaybeT manages early failure if we find a subgoal that + cannot be solved from instances. + +* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional + state that allows try_solve_from_instance to augment the evidence + bindings and inert_solved_dicts as it goes. + + If it succeeds, we commit all these bindings and solved dicts to the + main TcS InertSet. If not, we abandon it all entirely. + +Passing along the solved_dicts important for two reasons: + +* We need to be able to handle recursive super classes. The + solved_dicts state ensures that we remember what we have already + tried to solve to avoid looping. + +* As #15164 showed, it can be important to exploit sharing between + goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; + and to solve G2 we may need H. If we don't spot this sharing we may + solve H twice; and if this pattern repeats we may get exponentially bad + behaviour. + +Note [No Given/Given fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not create constraints from: +* Given/Given interactions via functional dependencies or type family + injectivity annotations. +* Given/instance fundep interactions via functional dependencies or + type family injectivity annotations. + +In this Note, all these interactions are called just "fundeps". + +We ingore such fundeps for several reasons: + +1. These fundeps will never serve a purpose in accepting more + programs: Given constraints do not contain metavariables that could + be unified via exploring fundeps. They *could* be useful in + discovering inaccessible code. However, the constraints will be + Wanteds, and as such will cause errors (not just warnings) if they + go unsolved. Maybe there is a clever way to get the right + inaccessible code warnings, but the path forward is far from + clear. #12466 has further commentary. + +2. Furthermore, here is a case where a Given/instance interaction is actively + harmful (from dependent/should_compile/RaeJobTalk): + + type family a == b :: Bool + type family Not a = r | r -> a where + Not False = True + Not True = False + + [G] Not (a == b) ~ True + + Reacting this Given with the equations for Not produces + + [W] a == b ~ False + + This is indeed a true consequence, and would make sense as a fresh Given. + But we don't have a way to produce evidence for fundeps, as a Wanted it + is /harmful/: we can't prove it, and so we'll report an error and reject + the program. (Previously fundeps gave rise to Deriveds, which + carried no evidence, so it didn't matter that they could not be proved.) + +3. #20922 showed a subtle different problem with Given/instance fundeps. + type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where + ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss + ... + + tclevel = 4 + [G] ZipCons is1 iss ~ (i : is2) : jss + + (The tclevel=4 means that this Given is at level 4.) The fundep tells us that + 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification + variable; we don't know what type it stands for. So we would emit + [W] iss ~ is2 : beta + + Again we can't prove that equality; and worse we'll rewrite iss to + (is2:beta) in deeply nested constraints inside this implication, + where beta is untouchable (under other equality constraints), leading + to other insoluble constraints. + +The bottom line: since we have no evidence for them, we should ignore Given/Given +and Given/instance fundeps entirely. +-} + +tryInertDicts :: DictCt -> SolverStage () +tryInertDicts dict_ct + = Stage $ do { inerts <- getInertCans + ; try_inert_dicts inerts dict_ct } + +try_inert_dicts :: InertCans -> DictCt -> TcS (StopOrContinue ()) +try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys }) + | Just dict_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + , let ev_i = dictCtEvidence dict_i + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + = -- There is a matching dictionary in the inert set + do { -- First to try to solve it /completely/ from top level instances + -- See Note [Shortcut solving] + dflags <- getDynFlags + ; short_cut_worked <- shortCutSolver dflags ev_w ev_i + ; if short_cut_worked + then stopWith ev_w "interactDict/solved from instance" + + -- Next see if we are in "loopy-superclass" land. If so, + -- we don't want to replace the (Given) inert with the + -- (Wanted) work-item, or vice versa; we want to hang on + -- to both, and try to solve the work-item via an instance. + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + else if prohibitedSuperClassSolve loc_i loc_w + then continueWith () + else + do { -- The short-cut solver didn't fire, and loopy superclasses + -- are dealt with, so we can either solve + -- the inert from the work-item or vice-versa. + ; case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of + KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w) + ; setEvBindIfWanted ev_w True (ctEvTerm ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) } + KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w) + ; setEvBindIfWanted ev_i True (ctEvTerm ev_w) + ; updInertCans (updDicts $ delDict dict_w) + ; continueWith () } } } + + | otherwise + = do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys) + ; continueWith () } + +-- See Note [Shortcut solving] +shortCutSolver :: DynFlags + -> CtEvidence -- Work item + -> CtEvidence -- Inert we want to try to replace + -> TcS Bool -- True <=> success +shortCutSolver dflags ev_w ev_i + | isWanted ev_w + , isGiven ev_i + -- We are about to solve a [W] constraint from a [G] constraint. We take + -- a moment to see if we can get a better solution using an instance. + -- Note that we only do this for the sake of performance. Exactly the same + -- programs should typecheck regardless of whether we take this step or + -- not. See Note [Shortcut solving] + + , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) + + , not (xopt LangExt.IncoherentInstances dflags) + -- If IncoherentInstances is on then we cannot rely on coherence of proofs + -- in order to justify this optimization: The proof provided by the + -- [G] constraint's superclass may be different from the top-level proof. + -- See Note [Shortcut solving: incoherence] + + , gopt Opt_SolveConstantDicts dflags + -- Enabled by the -fsolve-constant-dicts flag + + = do { ev_binds_var <- getTcEvBindsVar + ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $ + getTcEvBindsMap ev_binds_var + ; solved_dicts <- getSolvedDicts + + ; mb_stuff <- runMaybeT $ + try_solve_from_instance (ev_binds, solved_dicts) ev_w + + ; case mb_stuff of + Nothing -> return False + Just (ev_binds', solved_dicts') + -> do { setTcEvBindsMap ev_binds_var ev_binds' + ; setSolvedDicts solved_dicts' + ; return True } } + + | otherwise + = return False + where + -- This `CtLoc` is used only to check the well-staged condition of any + -- candidate DFun. Our subgoals all have the same stage as our root + -- [W] constraint so it is safe to use this while solving them. + loc_w = ctEvLoc ev_w + + try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] + :: (EvBindMap, DictMap DictCt) -> CtEvidence + -> MaybeT TcS (EvBindMap, DictMap DictCt) + try_solve_from_instance (ev_binds, solved_dicts) ev + | let pred = ctEvPred ev + , ClassPred cls tys <- classifyPredType pred + = do { inst_res <- lift $ matchGlobalInst dflags True cls tys + ; case inst_res of + OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , cir_canonical = canonical + , cir_what = what } + | safeOverlap what + , all isTyFamFree preds -- Note [Shortcut solving: type families] + -> do { let dict_ct = DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand } + solved_dicts' = addSolvedDict dict_ct solved_dicts + -- solved_dicts': it is important that we add our goal + -- to the cache before we solve! Otherwise we may end + -- up in a loop while solving recursive dictionaries. + + ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) + ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred + ; lift $ checkReductionDepth loc' pred + + + ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds + -- Emit work for subgoals but use our local cache + -- so we can solve recursive dictionaries. + + ; let ev_tm = mk_ev (map getEvExpr evc_vs) + ev_binds' = extendEvBinds ev_binds $ + mkWantedEvBind (ctEvEvId ev) canonical ev_tm + + ; foldlM try_solve_from_instance (ev_binds', solved_dicts') $ + freshGoals evc_vs } + + _ -> mzero } + + | otherwise + = mzero + + + -- Use a local cache of solved dicts while emitting EvVars for new work + -- We bail out of the entire computation if we need to emit an EvVar for + -- a subgoal that isn't a ClassPred. + new_wanted_cached :: CtEvidence -> CtLoc + -> DictMap DictCt -> TcPredType -> MaybeT TcS MaybeNew + new_wanted_cached ev_w loc cache pty + | ClassPred cls tys <- classifyPredType pty + = lift $ case findDict cache loc_w cls tys of + Just dict_ct -> return $ Cached (ctEvExpr (dictCtEvidence dict_ct)) + Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty + | otherwise = mzero + +{- ******************************************************************* +* * + Top-level reaction for class constraints (CDictCan) +* * +**********************************************************************-} + +tryInstances :: DictCt -> SolverStage () +tryInstances dict_ct + = Stage $ do { inerts <- getInertSet + ; try_instances inerts dict_ct } + +try_instances :: InertSet -> DictCt -> TcS (StopOrContinue ()) +-- Try to use type-class instance declarations to simplify the constraint +try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls + , di_tys = xis }) + | isGiven ev -- Never use instances for Given constraints + = continueWith () + -- See Note [No Given/Given fundeps] + + | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached + = do { setEvBindIfWanted ev True (ctEvTerm solved_ev) + ; stopWith ev "Dict/Top (cached)" } + + | otherwise -- Wanted, but not cached + = do { dflags <- getDynFlags + ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc + ; case lkup_res of + OneInst { cir_what = what } + -> do { insertSafeOverlapFailureTcS what work_item + ; updSolvedDicts what work_item + ; chooseInstance ev lkup_res } + _ -> -- NoInstance or NotSure + -- We didn't solve it; so try functional dependencies + continueWith () } + where + dict_loc = ctEvLoc ev + +chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue a) +chooseInstance work_item + (OneInst { cir_new_theta = theta + , cir_what = what + , cir_mk_ev = mk_ev + , cir_canonical = canonical }) + = do { traceTcS "doTopReact/found instance for" $ ppr work_item + ; deeper_loc <- checkInstanceOK loc what pred + ; checkReductionDepth deeper_loc pred + ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar) + (ppr work_item) + ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta + ; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (freshGoals evc_vars) + ; stopWith work_item "Dict/Top (solved wanted)" } + where + pred = ctEvPred work_item + loc = ctEvLoc work_item + +chooseInstance work_item lookup_res + = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) + +checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc +-- Check that it's OK to use this instance: +-- (a) the use is well staged in the Template Haskell sense +-- Returns the CtLoc to used for sub-goals +-- Probably also want to call checkReductionDepth +checkInstanceOK loc what pred + = do { checkWellStagedDFun loc what pred + ; return deeper_loc } + where + deeper_loc = zap_origin (bumpCtLocDepth loc) + origin = ctLocOrigin loc + + zap_origin loc -- After applying an instance we can set ScOrigin to + -- NotNakedSc, so that prohibitedSuperClassSolve never fires + -- See Note [Solving superclass constraints] in + -- GHC.Tc.TyCl.Instance, (sc1). + | ScOrigin what _ <- origin + = setCtLocOrigin loc (ScOrigin what NotNakedSc) + | otherwise + = loc + +matchClassInst :: DynFlags -> InertSet + -> Class -> [Type] + -> CtLoc -> TcS ClsInstResult +matchClassInst dflags inerts clas tys loc +-- First check whether there is an in-scope Given that could +-- match this constraint. In that case, do not use any instance +-- whether top level, or local quantified constraints. +-- See Note [Instance and Given overlap] + | not (xopt LangExt.IncoherentInstances dflags) + , not (isCTupleClass clas) + -- It is always safe to unpack constraint tuples + -- And if we don't do so, we may never solve it at all + -- See Note [Solving tuple constraints] + , not (noMatchableGivenDicts inerts loc clas tys) + = do { traceTcS "Delaying instance application" $ + vcat [ text "Work item:" <+> pprClassPred clas tys ] + ; return NotSure } + + | otherwise + = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' + ; local_res <- matchLocalInst pred loc + ; case local_res of + OneInst {} -> -- See Note [Local instances and incoherence] + do { traceTcS "} matchClassInst local match" $ ppr local_res + ; return local_res } + + NotSure -> -- In the NotSure case for local instances + -- we don't want to try global instances + do { traceTcS "} matchClassInst local not sure" empty + ; return local_res } + + NoInstance -- No local instances, so try global ones + -> do { global_res <- matchGlobalInst dflags False clas tys + ; traceTcS "} matchClassInst global result" $ ppr global_res + ; return global_res } } + where + pred = mkClassPred clas tys + +{- Note [Instance and Given overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example, from the OutsideIn(X) paper: + instance P x => Q [x] + instance (x ~ y) => R y [x] + + wob :: forall a b. (Q [b], R b a) => a -> Int + + g :: forall a. Q [a] => [a] -> Int + g x = wob x + +From 'g' we get the implication constraint: + forall a. Q [a] => (Q [beta], R beta [a]) +If we react (Q [beta]) with its top-level axiom, we end up with a +(P beta), which we have no way of discharging. On the other hand, +if we react R beta [a] with the top-level we get (beta ~ a), which +is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is +now solvable by the given Q [a]. + +The partial solution is that: + In matchClassInst (and thus in topReact), we return a matching + instance only when there is no Given in the inerts which is + unifiable to this particular dictionary. + + We treat any meta-tyvar as "unifiable" for this purpose, + *including* untouchable ones. But not skolems like 'a' in + the implication constraint above. + +The end effect is that, much as we do for overlapping instances, we +delay choosing a class instance if there is a possibility of another +instance OR a given to match our constraint later on. This fixes +tickets #4981 and #5002. + +Other notes: + +* The check is done *first*, so that it also covers classes + with built-in instance solving, such as + - constraint tuples + - natural numbers + - Typeable + +* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet. + +* The given-overlap problem is arguably not easy to appear in practice + due to our aggressive prioritization of equality solving over other + constraints, but it is possible. I've added a test case in + typecheck/should-compile/GivenOverlapping.hs + +* Another "live" example is #10195; another is #10177. + +* We ignore the overlap problem if -XIncoherentInstances is in force: + see #6002 for a worked-out example where this makes a + difference. + +* Moreover notice that our goals here are different than the goals of + the top-level overlapping checks. There we are interested in + validating the following principle: + + If we inline a function f at a site where the same global + instance environment is available as the instance environment at + the definition site of f then we should get the same behaviour. + + But for the Given Overlap check our goal is just related to completeness of + constraint solving. + +* The solution is only a partial one. Consider the above example with + g :: forall a. Q [a] => [a] -> Int + g x = let v = wob x + in v + and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most + general type for 'v'. When generalising v's type we'll simplify its + Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we + will use the instance declaration after all. #11948 was a case + in point. + +All of this is disgustingly delicate, so to discourage people from writing +simplifiable class givens, we warn about signatures that contain them; +see GHC.Tc.Validity Note [Simplifiable given constraints]. + + +Note [Local instances and incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) + => c b -> Bool + f x = x==x + +We get [W] Eq (c b), and we must use the local instance to solve it. + +BUT that wanted also unifies with the top-level Eq [a] instance, +and Eq (Maybe a) etc. We want the local instance to "win", otherwise +we can't solve the wanted at all. So we mark it as Incohherent. +According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll +make it win even if there are other instances that unify. + +Moreover this is not a hack! The evidence for this local instance +will be constructed by GHC at a call site... from the very instances +that unify with it here. It is not like an incoherent user-written +instance which might have utterly different behaviour. + +Consider f :: Eq a => blah. If we have [W] Eq a, we certainly +get it from the Eq a context, without worrying that there are +lots of top-level instances that unify with [W] Eq a! We'll use +those instances to build evidence to pass to f. That's just the +nullary case of what's happening here. +-} + +matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult +-- Look up the predicate in Given quantified constraints, +-- which are effectively just local instance declarations. +matchLocalInst pred loc + = do { inerts@(IS { inert_cans = ics }) <- getInertSet + ; case match_local_inst inerts (inert_insts ics) of + { ([], []) -> do { traceTcS "No local instance for" (ppr pred) + ; return NoInstance } + ; (matches, unifs) -> + do { matches <- mapM mk_instDFun matches + ; unifs <- mapM mk_instDFun unifs + -- See Note [Use only the best matching quantified constraint] + ; case dominatingMatch matches of + { Just (dfun_id, tys, theta) + | all ((theta `impliedBySCs`) . thdOf3) unifs + -> + do { let result = OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_canonical = True + , cir_what = LocalInstance } + ; traceTcS "Best local instance found:" $ + vcat [ text "pred:" <+> ppr pred + , text "result:" <+> ppr result + , text "matches:" <+> ppr matches + , text "unifs:" <+> ppr unifs ] + ; return result } + + ; mb_best -> + do { traceTcS "Multiple local instances; not committing to any" + $ vcat [ text "pred:" <+> ppr pred + , text "matches:" <+> ppr matches + , text "unifs:" <+> ppr unifs + , text "best_match:" <+> ppr mb_best ] + ; return NotSure }}}}} + where + pred_tv_set = tyCoVarsOfType pred + + mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun + mk_instDFun (ev, tys) = + let dfun_id = ctEvEvId ev + in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys + ; return (dfun_id, tys, theta) } + + -- Compute matching and unifying local instances + match_local_inst :: InertSet + -> [QCInst] + -> ( [(CtEvidence, [DFunInstType])] + , [(CtEvidence, [DFunInstType])] ) + match_local_inst _inerts [] + = ([], []) + match_local_inst inerts (qci@(QCI { qci_tvs = qtvs + , qci_pred = qpred + , qci_ev = qev }) + :qcis) + | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) + , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) + emptyTvSubstEnv qpred pred + , let match = (qev, map (lookupVarEnv tv_subst) qtvs) + = (match:matches, unifs) + + | otherwise + = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred)) + (ppr qci $$ ppr pred) + -- ASSERT: unification relies on the + -- quantified variables being fresh + (matches, this_unif `combine` unifs) + where + qloc = ctEvLoc qev + qtv_set = mkVarSet qtvs + (matches, unifs) = match_local_inst inerts qcis + this_unif + | Just subst <- mightEqualLater inerts qpred qloc pred loc + = Just (qev, map (lookupTyVar subst) qtvs) + | otherwise + = Nothing + + combine Nothing us = us + combine (Just u) us = u : us + +-- | Instance dictionary function and type. +type InstDFun = (DFunId, [TcType], TcThetaType) + +-- | Try to find a local quantified instance that dominates all others, +-- i.e. which has a weaker instance context than all the others. +-- +-- See Note [Use only the best matching quantified constraint]. +dominatingMatch :: [InstDFun] -> Maybe InstDFun +dominatingMatch matches = + listToMaybe $ mapMaybe (uncurry go) (holes matches) + -- listToMaybe: arbitrarily pick any one context that is weaker than + -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a] + -- (see test case T22223). + + where + go :: InstDFun -> [InstDFun] -> Maybe InstDFun + go this [] = Just this + go this@(_,_,this_theta) ((_,_,other_theta):others) + | this_theta `impliedBySCs` other_theta + = go this others + | otherwise + = Nothing + +-- | Whether a collection of constraints is implied by another collection, +-- according to a simple superclass check. +-- +-- See Note [When does a quantified instance dominate another?]. +impliedBySCs :: TcThetaType -> TcThetaType -> Bool +impliedBySCs c1 c2 = all in_c2 c1 + where + in_c2 :: TcPredType -> Bool + in_c2 pred = any (pred `tcEqType`) c2_expanded + + c2_expanded :: [TcPredType] -- Includes all superclasses + c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ] + + +{- Note [When does a quantified instance dominate another?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching local quantified instances, it's useful to be able to pick +the one with the weakest precondition, e.g. if one has both + + [G] d1: forall a b. ( Eq a, Num b, C a b ) => D a b + [G] d2: forall a . C a Int => D a Int + [W] {w}: D a Int + +Then it makes sense to use d2 to solve w, as doing so we end up with a strictly +weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)` +were we to use d1. + +In theory, to compute whether one context implies another, we would need to +recursively invoke the constraint solver. This is expensive, so we instead do +a simple check using superclasses, implemented in impliedBySCs. + +Examples: + + - [Eq a] is implied by [Ord a] + - [Ord a] is not implied by [Eq a], + - any context is implied by itself, + - the empty context is implied by any context. + +Note [Use only the best matching quantified constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#20582) the ambiguity check for + (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int + +Because of eager expansion of given superclasses, we get + [G] d1: forall a. Ord (m a) + [G] d2: forall a. Eq (m a) + [G] d3: forall a. Semigroup a => Eq (m a) + + [W] {w1}: forall a. Ord (m a) + [W] {w2}: forall a. Semigroup a => Eq (m a) + +The first wanted is solved straightforwardly. But the second wanted +matches *two* local instances: d2 and d3. Our general rule around multiple local +instances is that we refuse to commit to any of them. However, that +means that our type fails the ambiguity check. That's bad: the type +is perfectly fine. (This actually came up in the wild, in the streamly +library.) + +The solution is to prefer local instances which are easier to prove, meaning +that they have a weaker precondition. In this case, the empty context +of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer +using it when proving w2. This allows us to pass the ambiguity check here. + +Our criterion for solving a Wanted by matching local quantified instances is +thus as follows: + + - There is a matching local quantified instance that dominates all others + matches, in the sense of [When does a quantified instance dominate another?]. + Any such match do, we pick it arbitrarily (the T22223 example below says why). + - This local quantified instance also dominates all the unifiers, as we + wouldn't want to commit to a single match when we might have multiple, + genuinely different matches after further unification takes place. + +Some other examples: + + + #15244: + + f :: (C g, D g) => .... + class S g => C g where ... + class S g => D g where ... + class (forall a. Eq a => Eq (g a)) => S g where ... + + Here, in f's RHS, there are two identical quantified constraints + available, one via the superclasses of C and one via the superclasses + of D. Given that each implies the other, we pick one arbitrarily. + + + #22216: + + class Eq a + class Eq a => Ord a + class (forall b. Eq b => Eq (f b)) => Eq1 f + class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f + + Suppose we have + + [G] d1: Ord1 f + [G] d2: Eq a + [W] {w}: Eq (f a) + + Superclass expansion of d1 gives us: + + [G] d3 : Eq1 f + [G] d4 : forall b. Ord b => Ord (f b) + + expanding d4 and d5 gives us, respectively: + + [G] d5 : forall b. Eq b => Eq (f b) + [G] d6 : forall b. Ord b => Eq (f b) + + Now we have two matching local instances that we could use when solving the + Wanted. However, it's obviously silly to use d6, given that d5 provides us with + as much information, with a strictly weaker precondition. So we pick d5 to solve + w. If we chose d6, we would get [W] Ord a, which in this case we can't solve. + + + #22223: + + [G] forall a b. (Eq a, Ord b) => C a b + [G] forall a b. (Ord b, Eq a) => C a b + [W] C x y + + Here we should be free to pick either quantified constraint, as they are + equivalent up to re-ordering of the constraints in the context. + See also Note [Do not add duplicate quantified instances] + in GHC.Tc.Solver.Monad. + +Test cases: + typecheck/should_compile/T20582 + quantified-constraints/T15244 + quantified-constraints/T22216{a,b,c,d,e} + quantified-constraints/T22223 + +Historical note: a previous solution was to instead pick the local instance +with the least superclass depth (see Note [Replacement vs keeping]), +but that doesn't work for the example from #22216. +-} + +{- ******************************************************************* +* * + Last resort prohibited superclass +* * +**********************************************************************-} + +tryLastResortProhibitedSuperClass :: DictCt -> SolverStage () +-- ^ As a last resort, we TEMPORARILY allow a prohibited superclass solve, +-- emitting a loud warning when doing so: we might be creating non-terminating +-- evidence (as we are in T22912 for example). +-- +-- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance. +tryLastResortProhibitedSuperClass dict_ct + = Stage $ do { inerts <- getInertCans + ; last_resort inerts dict_ct } + +last_resort :: InertCans -> DictCt -> TcS (StopOrContinue ()) +last_resort inerts (DictCt { di_ev = ev_w, di_cls = cls, di_tys = xis }) + | let loc_w = ctEvLoc ev_w + orig_w = ctLocOrigin loc_w + , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted + , Just ct_i <- lookupInertDict inerts loc_w cls xis + , let ev_i = dictCtEvidence ct_i + , isGiven ev_i + = do { setEvBindIfWanted ev_w True (ctEvTerm ev_i) + ; ctLocWarnTcS loc_w $ + TcRnLoopySuperclassSolve loc_w (ctEvPred ev_w) + ; return $ Stop ev_w (text "Loopy superclass") } + | otherwise + = continueWith () + + +{- ********************************************************************* +* * +* Functional dependencies, instantiation of equations +* * +************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer +now!). + +Note [FunDep and implicit parameter reactions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, our story of interacting two dictionaries (or a dictionary +and top-level instances) for functional dependencies, and implicit +parameters, is that we simply produce new Wanted equalities. So for example + + class D a b | a -> b where ... + Inert: + d1 :g D Int Bool + WorkItem: + d2 :w D Int alpha + + We generate the extra work item + cv :w alpha ~ Bool + where 'cv' is currently unused. However, this new item can perhaps be + spontaneously solved to become given and react with d2, + discharging it in favour of a new constraint d2' thus: + d2' :w D Int Bool + d2 := d2' |> D Int cv + Now d2' can be discharged from d1 + +We could be more aggressive and try to *immediately* solve the dictionary +using those extra equalities. + +If that were the case with the same inert set and work item we might discard +d2 directly: + + cv :w alpha ~ Bool + d2 := d1 |> D Int cv + +But in general it's a bit painful to figure out the necessary coercion, +so we just take the first approach. Here is a better example. Consider: + class C a b c | a -> b +And: + [Given] d1 : C T Int Char + [Wanted] d2 : C T beta Int +In this case, it's *not even possible* to solve the wanted immediately. +So we should simply output the functional dependency and add this guy +[but NOT its superclasses] back in the worklist. Even worse: + [Given] d1 : C T Int beta + [Wanted] d2: C T beta Int +Then it is solvable, but its very hard to detect this on the spot. + +It's exactly the same with implicit parameters, except that the +"aggressive" approach would be much easier to implement. + +Note [Fundeps with instances, and equality orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes a delicate interaction that constrains the orientation of +equalities. This one is about fundeps, but the /exact/ same thing arises for +type-family injectivity constraints: see Note [Improvement orientation]. + +doTopFunDepImprovement compares the constraint with all the instance +declarations, to see if we can produce any equalities. E.g + class C2 a b | a -> b + instance C Int Bool +Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. + +There is a nasty corner in #19415 which led to the typechecker looping: + class C s t b | s -> t + instance ... => C (T kx x) (T ky y) Int + T :: forall k. k -> Type + + work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char + where kb0, b0 are unification vars + + ==> {doTopFunDepImprovement: compare work_item with instance, + generate /fresh/ unification variables kfresh0, yfresh0, + emit a new Wanted, and add dwrk to inert set} + + Suppose we emit this new Wanted from the fundep: + [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) + + ==> {solve that equality kb0 := kfresh0, b0 := yfresh0} + Now kick out dwrk, since it mentions kb0 + But now we are back to the start! Loop! + +NB1: This example relies on an instance that does not satisfy the + coverage condition (although it may satisfy the weak coverage + condition), and hence whose fundeps generate fresh unification + variables. Not satisfying the coverage condition is known to + lead to termination trouble, but in this case it's plain silly. + +NB2: In this example, the third parameter to C ensures that the + instance doesn't actually match the Wanted, so we can't use it to + solve the Wanted + +We solve the problem by (#21703): + + carefully orienting the new Wanted so that all the + freshly-generated unification variables are on the LHS. + + Thus we call unifyWanteds on + T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + and /NOT/ + T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) + +Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well. The general idea +is that we want to preferentially eliminate those freshly-generated +unification variables, rather than unifying older variables, which causes +kick-out etc. + +Keeping younger variables on the left also gives very minor improvement in +the compiler performance by having less kick-outs and allocations (-0.1% on +average). Indeed Historical Note [Eliminate younger unification variables] +in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically, +apparently now in abeyance. + +But this is is a delicate solution. We must take care to /preserve/ +orientation during solving. Wrinkles: + +(W1) We start with + [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + Decompose to + [W] kfresh0 ~ kb0 + [W] (yfresh0::kfresh0) ~ (b0::kb0) + Preserve orientiation when decomposing!! + +(W2) Suppose we happen to tackle the second Wanted from (W1) + first. Then in canEqCanLHSHetero we emit a /kind/ equality, as + well as a now-homogeneous type equality + [W] kco : kfresh0 ~ kb0 + [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco) + Preserve orientation in canEqCanLHSHetero!! (Failing to + preserve orientation here was the immediate cause of #21703.) + +(W3) There is a potential interaction with the swapping done by + GHC.Tc.Utils.Unify.swapOverTyVars. We think it's fine, but it's + a slight worry. See especially Note [TyVar/TyVar orientation] in + that module. + +The trouble is that "preserving orientation" is a rather global invariant, +and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't +even have a precise statement of what the invariant is. The advantage +of the preserve-orientation plan is that it is extremely cheap to implement, +and apparently works beautifully. + +--- Alternative plan (1) --- +Rather than have an ill-defined invariant, another possiblity is to +elminate those fresh unification variables at birth, when generating +the new fundep-inspired equalities. + +The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those +type variables that are guaranteed to give us some progress. This means we +have to locally (without calling emitWanteds) identify the type variables +that do not give us any progress. In the above example, we _know_ that +emitting the two wanteds `kco` and `co` is fruitless. + + Q: How do we identify such no-ops? + + 1. Generate a matching substitution from LHS to RHS + ɸ = [kb0 :-> k0, b0 :-> y0] + 2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ + ɸ' = instFlexiX ɸ (tvs - domain ɸ) + 3. Apply ɸ' on LHS and then call emitWanteds + unifyWanteds ... (subst ɸ' LHS) RHS + +Why will this work? The matching substitution ɸ will be a best effort +substitution that gives us all the easy solutions. It can be generated with +modified version of `Core/Unify.unify_tys` where we run it in a matching mode +and never generate `SurelyApart` and always return a `MaybeApart Subst` +instead. + +The same alternative plan would work for type-family injectivity constraints: +see Note [Improvement orientation] in GHC.Tc.Solver.Equality. +--- End of Alternative plan (1) --- + +--- Alternative plan (2) --- +We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo) +for the fresh unification variables introduced by functional dependencies. Say `FunDepTv`. Then in +GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible. +Looks possible, but it's one more complication. +--- End of Alternative plan (2) --- + + +--- Historical note: Failed Alternative Plan (3) --- +Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False +once we used a fun dep to hint the solver to break and to stop emitting more +wanteds. This solution was not complete, and caused a failures while trying +to solve for transitive functional dependencies (test case: T21703) +-- End of Historical note: Failed Alternative Plan (3) -- + +Note [Do fundeps last] +~~~~~~~~~~~~~~~~~~~~~~ +Consider T4254b: + class FD a b | a -> b where { op :: a -> b } + + instance FD Int Bool + + foo :: forall a b. (a~Int,FD a b) => a -> Bool + foo = op + +(DFL1) Try local fundeps first. + From the ambiguity check on the type signature we get + [G] FD Int b + [W] FD Int beta + Interacting these gives beta:=b; then we start again and solve without + trying fundeps between the new [W] FD Int b and the top-level instance. + If we did, we'd generate [W] b ~ Bool, which fails. + +(DFL2) Try solving from top-level instances before fundeps + From the definition `foo = op` we get + [G] FD Int b + [W] FD Int Bool + We solve this from the top level instance before even trying fundeps. + If we did try fundeps, we'd generate [W] b ~ Bool, which fails. + + +Note [Weird fundeps] +~~~~~~~~~~~~~~~~~~~~ +Consider class Het a b | a -> b where + het :: m (f c) -> a -> m b + + class GHet (a :: * -> *) (b :: * -> *) | a -> b + instance GHet (K a) (K [a]) + instance Het a b => GHet (K a) (K b) + +The two instances don't actually conflict on their fundeps, +although it's pretty strange. So they are both accepted. Now +try [W] GHet (K Int) (K Bool) +This triggers fundeps from both instance decls; + [W] K Bool ~ K [a] + [W] K Bool ~ K beta +And there's a risk of complaining about Bool ~ [a]. But in fact +the Wanted matches the second instance, so we never get as far +as the fundeps. + +#7875 is a case in point. +-} + +doLocalFunDepImprovement :: DictCt -> SolverStage () +-- Add wanted constraints from type-class functional dependencies. +doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls }) + = Stage $ + do { inerts <- getInertCans + ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls) + ; if imp then startAgainWith (CDictCan dict_ct) + else continueWith () } + where + work_pred = ctEvPred work_ev + work_loc = ctEvLoc work_ev + + add_fds :: Bool -> DictCt -> TcS Bool + add_fds so_far (DictCt { di_ev = inert_ev }) + | isGiven work_ev && isGiven inert_ev + -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] + = return so_far + | otherwise + = do { traceTcS "doLocalFunDepImprovement" (vcat + [ ppr work_ev + , pprCtLoc work_loc, ppr (isGivenLoc work_loc) + , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) + , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) + + ; unifs <- emitFunDepWanteds work_ev $ + improveFromAnother (derived_loc, inert_rewriters) + inert_pred work_pred + ; return (so_far || unifs) + } + where + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` + ctl_depth inert_loc + , ctl_origin = FunDepOrigin1 work_pred + (ctLocOrigin work_loc) + (ctLocSpan work_loc) + inert_pred + (ctLocOrigin inert_loc) + (ctLocSpan inert_loc) } + +doTopFunDepImprovement :: DictCt -> SolverStage () +-- Try to functional-dependency improvement between the constraint +-- and the top-level instance declarations +-- See Note [Fundeps with instances, and equality orientation] +-- See also Note [Weird fundeps] +doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) + | isGiven ev -- No improvement for Givens + = Stage $ continueWith () + | otherwise + = Stage $ + do { traceTcS "try_fundeps" (ppr dict_ct) + ; instEnvs <- getInstEnvs + ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis + ; imp <- emitFunDepWanteds ev fundep_eqns + ; if imp then startAgainWith (CDictCan dict_ct) + else continueWith () } + where + dict_pred = mkClassPred cls xis + dict_loc = ctEvLoc ev + dict_origin = ctLocOrigin dict_loc + + mk_ct_loc :: PredType -- From instance decl + -> SrcSpan -- also from instance deol + -> (CtLoc, RewriterSet) + mk_ct_loc inst_pred inst_loc + = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin + inst_pred inst_loc } + , emptyRewriterSet ) + + +{- ********************************************************************* +* * +* Superclasses +* * +********************************************************************* -} + +{- Note [The superclass story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to add superclass constraints for two reasons: + +* For givens [G], they give us a route to proof. E.g. + f :: Ord a => a -> Bool + f x = x == x + We get a Wanted (Eq a), which can only be solved from the superclass + of the Given (Ord a). + +* For wanteds [W], they may give useful + functional dependencies. E.g. + class C a b | a -> b where ... + class C a b => D a b where ... + Now a [W] constraint (D Int beta) has (C Int beta) as a superclass + and that might tell us about beta, via C's fundeps. We can get this + by generating a [W] (C Int beta) constraint. We won't use the evidence, + but it may lead to unification. + +See Note [Why adding superclasses can help]. + +For these reasons we want to generate superclass constraints for both +Givens and Wanteds. But: + +* (Minor) they are often not needed, so generating them aggressively + is a waste of time. + +* (Major) if we want recursive superclasses, there would be an infinite + number of them. Here is a real-life example (#10318); + + class (Frac (Frac a) ~ Frac a, + Fractional (Frac a), + IntegralDomain (Frac a)) + => IntegralDomain a where + type Frac a :: * + + Notice that IntegralDomain has an associated type Frac, and one + of IntegralDomain's superclasses is another IntegralDomain constraint. + +So here's the plan: + +1. Eagerly generate superclasses for given (but not wanted) + constraints; see Note [Eagerly expand given superclasses]. + This is done using mkStrictSuperClasses in canClassNC, when + we take a non-canonical Given constraint and cannonicalise it. + + However stop if you encounter the same class twice. That is, + mkStrictSuperClasses expands eagerly, but has a conservative + termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType. + +2. Solve the wanteds as usual, but do no further expansion of + superclasses for canonical CDictCans in solveSimpleGivens or + solveSimpleWanteds; Note [Danger of adding superclasses during solving] + + However, /do/ continue to eagerly expand superclasses for new /given/ + /non-canonical/ constraints (canClassNC does this). As #12175 + showed, a type-family application can expand to a class constraint, + and we want to see its superclasses for just the same reason as + Note [Eagerly expand given superclasses]. + +3. If we have any remaining unsolved wanteds + (see Note [When superclasses help] in GHC.Tc.Types.Constraint) + try harder: take both the Givens and Wanteds, and expand + superclasses again. See the calls to expandSuperClasses in + GHC.Tc.Solver.simpl_loop and solveWanteds. + + This may succeed in generating (a finite number of) extra Givens, + and extra Wanteds. Both may help the proof. + +3a An important wrinkle: only expand Givens from the current level. + Two reasons: + - We only want to expand it once, and that is best done at + the level it is bound, rather than repeatedly at the leaves + of the implication tree + - We may be inside a type where we can't create term-level + evidence anyway, so we can't superclass-expand, say, + (a ~ b) to get (a ~# b). This happened in #15290. + +4. Go round to (2) again. This loop (2,3,4) is implemented + in GHC.Tc.Solver.simpl_loop. + +The cc_pend_sc field in a CDictCan records whether the superclasses of +this constraint have been expanded. Specifically, in Step 3 we only +expand superclasses for constraints with cc_pend_sc > 0 +(i.e. isPendingScDict holds). +See Note [Expanding Recursive Superclasses and ExpansionFuel] + +Why do we do this? Two reasons: + +* To avoid repeated work, by repeatedly expanding the superclasses of + same constraint, + +* To terminate the above loop, at least in the -XNoUndecidableSuperClasses + case. If there are recursive superclasses we could, in principle, + expand forever, always encountering new constraints. + +When we take a CNonCanonical or CIrredCan, but end up classifying it +as a CDictCan, we set the cc_pend_sc flag to False. + +Note [Superclass loops] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class C a => D a + class D a => C a + +Then, when we expand superclasses, we'll get back to the self-same +predicate, so we have reached a fixpoint in expansion and there is no +point in fruitlessly expanding further. This case just falls out from +our strategy. Consider + f :: C a => a -> Bool + f x = x==x +Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses +G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its cc_pend_sc has pending +expansion fuel.) +When processing d3 we find a match with d1 in the inert set, and we always +keep the inert item (d1) if possible: see Note [Replacement vs keeping] in +GHC.Tc.Solver.InertSet. So d3 dies a quick, happy death. + +Note [Eagerly expand given superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step (1) of Note [The superclass story], why do we eagerly expand +Given superclasses by one layer? (By "one layer" we mean expand transitively +until you meet the same class again -- the conservative criterion embodied +in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) +We do this eagerly for Givens mainly because of some very obscure +cases like this: + + instance Bad a => Eq (T a) + + f :: (Ord (T a)) => blah + f x = ....needs Eq (T a), Ord (T a).... + +Here if we can't satisfy (Eq (T a)) from the givens we'll use the +instance declaration; but then we are stuck with (Bad a). Sigh. +This is really a case of non-confluent proofs, but to stop our users +complaining we expand one layer in advance. + +See Note [Instance and Given overlap]. + +We also want to do this if we have + + f :: F (T a) => blah + +where + type instance F (T a) = Ord (T a) + +So we may need to do a little work on the givens to expose the +class that has the superclasses. That's why the superclass +expansion for Givens happens in canClassNC. + +This same scenario happens with quantified constraints, whose superclasses +are also eagerly expanded. Test case: typecheck/should_compile/T16502b +These are handled in canForAllNC, analogously to canClassNC. + +Note [Why adding superclasses can help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Examples of how adding superclasses can help: + + --- Example 1 + class C a b | a -> b + Suppose we want to solve + [G] C a b + [W] C a beta + Then adding [W] beta~b will let us solve it. + + -- Example 2 (similar but using a type-equality superclass) + class (F a ~ b) => C a b + And try to sllve: + [G] C a b + [W] C a beta + Follow the superclass rules to add + [G] F a ~ b + [W] F a ~ beta + Now we get [W] beta ~ b, and can solve that. + + -- Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + + When solving the superclasses of the (C (Maybe a) a) instance, we get + [G] C a b, and hence by superclasses, [G] G a, [G] L a b + [W] G (Maybe a) + Use the instance decl to get + [W] C a beta + Generate its superclass + [W] L a beta. Now using fundeps, combine with [G] L a b to get + [W] beta ~ b + which is what we want. + +Note [Danger of adding superclasses during solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a serious, but now out-dated example, from #4497: + + class Num (RealOf t) => Normed t + type family RealOf x + +Assume the generated wanted constraint is: + [W] RealOf e ~ e + [W] Normed e + +If we were to be adding the superclasses during simplification we'd get: + [W] RealOf e ~ e + [W] Normed e + [W] RealOf e ~ fuv + [W] Num fuv +==> + e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv + +While looks exactly like our original constraint. If we add the +superclass of (Normed fuv) again we'd loop. By adding superclasses +definitely only once, during canonicalisation, this situation can't +happen. + +Note [Nested quantified constraint superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/T17202) + + class C1 a + class (forall c. C1 c) => C2 a + class (forall b. (b ~ F a) => C2 a) => C3 a + +Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass +to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a +superclass, as well. But we now must be careful: we cannot just add +(forall c. C1 c) as a Given, because we need to remember g2's context. +That new constraint is Given only when forall b. (b ~ F a) is true. + +It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), +but that's problematic, because it's nested, and ForAllPred is not capable +of representing a nested quantified constraint. (We could change ForAllPred +to allow this, but the solution in this Note is much more local and simpler.) + +So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). + +More generally, if we are expanding the superclasses of + g0 :: forall tvs. theta => cls tys +and find a superclass constraint + forall sc_tvs. sc_theta => sc_inner_pred +we must have a selector + sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred +and thus build + g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids. + sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids + +Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the +last bound variables and the last arguments. This avoids the need to produce +the sc_theta_ids at all. So our final construction is + + g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. + sel_id tys (g0 tvs theta_ids) sc_tvs + + -} + +makeSuperClasses :: [Ct] -> TcS [Ct] +-- Returns strict superclasses, transitively, see Note [The superclass story] +-- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType +-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s +-- superclasses, up to /and including/ the first repetition of C +-- +-- Example: class D a => C a +-- class C [a] => D a +-- makeSuperClasses (C x) will return (D x, C [x]) +-- +-- NB: the incoming constraint's superclass will consume a unit of fuel +-- Preconditions on `cts`: 1. They are either `CDictCan` or `CQuantCan` +-- 2. Their fuel (stored in cc_pend_sc or qci_pend_sc) is > 0 +makeSuperClasses cts = concatMapM go cts + where + go (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = tys, di_pend_sc = fuel })) + = assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always + mkStrictSuperClasses fuel ev [] [] cls tys + go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel })) + = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have + -- class pred heads + assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always + mkStrictSuperClasses fuel ev tvs theta cls tys + where + (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) + go ct = pprPanic "makeSuperClasses" (ppr ct) + +mkStrictSuperClasses + :: ExpansionFuel -> CtEvidence + -> [TyVar] -> ThetaType -- These two args are non-empty only when taking + -- superclasses of a /quantified/ constraint + -> Class -> [Type] -> TcS [Ct] +-- Return constraints for the strict superclasses of +-- ev :: forall as. theta => cls tys +-- Precondition: fuel > 0 +-- Postcondition: fuel for recursive superclass ct is one unit less than cls fuel +mkStrictSuperClasses fuel ev tvs theta cls tys + = mk_strict_superclasses (consumeFuel fuel) (unitNameSet (className cls)) + ev tvs theta cls tys + +mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcS [Ct] +-- Always return the immediate superclasses of (cls tys); +-- and expand their superclasses, provided none of them are in rec_clss +-- nor are repeated +-- The caller of this function is supposed to perform fuel book keeping +-- Precondition: fuel >= 0 +mk_strict_superclasses _ _ _ _ _ cls _ + | isEqualityClass cls + = return [] + +mk_strict_superclasses fuel rec_clss + ev@(CtGiven { ctev_evar = evar, ctev_loc = loc }) + tvs theta cls tys + = -- Given case + do { traceTcS "mk_strict" (ppr ev $$ ppr (ctLocOrigin loc)) + ; concatMapM do_one_given (classSCSelIds cls) } + where + dict_ids = mkTemplateLocals theta + this_size = pSizeClassPred cls tys + + do_one_given sel_id + | isUnliftedType sc_pred + -- NB: class superclasses are never representation-polymorphic, + -- so isUnliftedType is OK here. + , not (null tvs && null theta) + = -- See Note [Equality superclasses in quantified constraints] + return [] + | otherwise + = do { given_ev <- newGivenEvVar sc_loc $ + mk_given_desc sel_id sc_pred + ; assertFuelPrecondition fuel $ + mk_superclasses fuel rec_clss given_ev tvs theta sc_pred } + where + sc_pred = classMethodInstTy sel_id tys + + -- See Note [Nested quantified constraint superclasses] + mk_given_desc :: Id -> PredType -> (PredType, EvTerm) + mk_given_desc sel_id sc_pred + = (swizzled_pred, swizzled_evterm) + where + (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred + (sc_theta, sc_inner_pred) = splitFunTys sc_rho + + all_tvs = tvs `chkAppend` sc_tvs + all_theta = theta `chkAppend` (map scaledThing sc_theta) + swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred + + -- evar :: forall tvs. theta => cls tys + -- sel_id :: forall cls_tvs. cls cls_tvs + -- -> forall sc_tvs. sc_theta => sc_inner_pred + -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + swizzled_evterm = EvExpr $ + mkLams all_tvs $ + mkLams dict_ids $ + Var sel_id + `mkTyApps` tys + `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) + `mkVarApps` sc_tvs + + sc_loc | isCTupleClass cls = loc + | otherwise = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) } + -- isCTupleClass: we don't want tuples to mess up the size calculations + -- of Note [Solving superclass constraints]. For tuple predicates, this + -- matters, because their size can be large, and we don't want to add a + -- big class to the size of the dictionaries in the chain. When we get + -- down to a base predicate, we'll include its size. See #10335. + -- See Note [Solving tuple constraints] + + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in + -- GHC.Tc.Solver.InertSet for why we need depths + mk_sc_origin :: CtOrigin -> CtOrigin + mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked) + = GivenSCOrigin skol_info (sc_depth + 1) + (already_blocked || newly_blocked skol_info) + + mk_sc_origin (GivenOrigin skol_info) + = -- These cases do not already have a superclass constraint: depth starts at 1 + GivenSCOrigin skol_info 1 (newly_blocked skol_info) + + mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $ + ppr evar $$ ppr other_orig + + newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size) + newly_blocked _ = False + +-- Wanted case +mk_strict_superclasses fuel rec_clss ev tvs theta cls tys + | all noFreeVarsOfType tys + = return [] -- Wanteds with no variables yield no superclass constraints. + -- See Note [Improvement from Ground Wanteds] + + | otherwise -- Wanted case, just add Wanted superclasses + -- that can lead to improvement. + = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ + concatMapM do_one (immSuperClasses cls tys) + where + loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) + + do_one sc_pred + = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred) + ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred + ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred } + +{- Note [Improvement from Ground Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose class C b a => D a b +and consider + [W] D Int Bool +Is there any point in emitting [W] C Bool Int? No! The only point of +emitting superclass constraints for W constraints is to get +improvement, extra unifications that result from functional +dependencies. See Note [Why adding superclasses can help] above. + +But no variables means no improvement; case closed. +-} + +mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] +-- Return this constraint, plus its superclasses, if any +-- Precondition: fuel >= 0 +mk_superclasses fuel rec_clss ev tvs theta pred + | ClassPred cls tys <- classifyPredType pred + = assertFuelPrecondition fuel $ + mk_superclasses_of fuel rec_clss ev tvs theta cls tys + + | otherwise -- Superclass is not a class predicate + = return [mkNonCanonical ev] + +mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> Class -> [Type] + -> TcS [Ct] +-- Always return this class constraint, +-- and expand its superclasses +-- Precondition: fuel >= 0 +mk_superclasses_of fuel rec_clss ev tvs theta cls tys + | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) + ; assertFuelPrecondition fuel $ return [mk_this_ct fuel] } + -- cc_pend_sc of returning ct = fuel + | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys + , ppr (isCTupleClass cls) + , ppr rec_clss + ]) + ; sc_cts <- assertFuelPrecondition fuel $ + mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys + ; return (mk_this_ct doNotExpand : sc_cts) } + -- doNotExpand: we have expanded this cls's superclasses, so + -- exhaust the associated constraint's fuel, + -- to avoid duplicate work + where + cls_nm = className cls + loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss + -- Tuples never contribute to recursion, and can be nested + rec_clss' = rec_clss `extendNameSet` cls_nm + + mk_this_ct :: ExpansionFuel -> Ct + -- We can't use CNonCanonical here because we need to tradk the fuel + mk_this_ct fuel | null tvs, null theta + = CDictCan (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = fuel }) + -- NB: If there is a loop, we cut off, so we have not + -- added the superclasses, hence cc_pend_sc = fuel + | otherwise + = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys + , qci_ev = ev, qci_pend_sc = fuel }) + + +{- Note [Equality superclasses in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#15359, #15593, #15625) + f :: (forall a. theta => a ~ b) => stuff + +It's a bit odd to have a local, quantified constraint for `(a~b)`, +but some people want such a thing (see the tickets). And for +Coercible it is definitely useful + f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) + => stuff + +Moreover it's not hard to arrange; we just need to look up /equality/ +constraints in the quantified-constraint environment, which we do in +GHC.Tc.Solver.Equality.tryQCsEqCt. + +There is a wrinkle though, in the case where 'theta' is empty, so +we have + f :: (forall a. a~b) => stuff + +Now, potentially, the superclass machinery kicks in, in +makeSuperClasses, giving us a a second quantified constraint + (forall a. a ~# b) +BUT this is an unboxed value! And nothing has prepared us for +dictionary "functions" that are unboxed. Actually it does just +about work, but the simplifier ends up with stuff like + case (/\a. eq_sel d) of df -> ...(df @Int)... +and fails to simplify that any further. And it doesn't satisfy +isPredTy any more. + +So for now we simply decline to take superclasses in the quantified +case. Instead we have a special case in GHC.Tc.Solver.Equality.tryQCsEqCt +which looks for primitive equalities specially in the quantified +constraints. + +See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. +-} diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Equality.hs @@ -0,0 +1,3190 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Solver.Equality( + solveEquality + ) where + + +import GHC.Prelude + +import GHC.Tc.Solver.Irred( solveIrred ) +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Rewrite +import GHC.Tc.Solver.Monad +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Types( findFunEqsByTyCon ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) +import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) + +import GHC.Core.Type +import GHC.Core.Predicate +import GHC.Core.Class +import GHC.Core.DataCon ( dataConName ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.Reduction +import GHC.Core.Unify( tcUnifyTyWithTFs ) +import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck + , lookupFamInstEnvByTyCon ) +import GHC.Core + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set( anyVarSet ) +import GHC.Types.Name.Reader +import GHC.Types.Basic + +import GHC.Builtin.Types ( anyTypeOfKind ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Constants( debugIsOn ) + +import GHC.Data.Pair +import GHC.Data.Bag +import Control.Monad +import Data.Maybe ( isJust, isNothing ) +import Data.List ( zip4 ) + +import qualified Data.Semigroup as S +import Data.Bifunctor ( bimap ) +import Data.Void( Void ) + +{- ********************************************************************* +* * +* Equalities +* * +************************************************************************ + +Note [Canonicalising equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to canonicalise an equality, we look at the structure of the +two types at hand, looking for similarities. A difficulty is that the +types may look dissimilar before rewriting but similar after rewriting. +However, we don't just want to jump in and rewrite right away, because +this might be wasted effort. So, after looking for similarities and failing, +we rewrite and then try again. Of course, we don't want to loop, so we +track whether or not we've already rewritten. + +It is conceivable to do a better job at tracking whether or not a type +is rewritten, but this is left as future work. (Mar '15) + +Note [Decomposing FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~ +can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This +means that we may very well have a FunTy containing a type of some +unknown kind. For instance, we may have, + + FunTy (a :: k) Int + +Where k is a unification variable. So the calls to splitRuntimeRep_maybe may +fail (returning Nothing). In that case we'll fall through, zonk, and try again. +Zonking should fill the variable k, meaning that decomposition will succeed the +second time around. + +Also note that we require the FunTyFlag to match. This will stop +us decomposing + (Int -> Bool) ~ (Show a => blah) +It's as if we treat (->) and (=>) as different type constructors, which +indeed they are! +-} + +solveEquality :: CtEvidence -> EqRel -> Type -> Type + -> SolverStage Void +solveEquality ev eq_rel ty1 ty2 + = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 + ; let ev' | debugIsOn = setCtEvPredType ev $ + mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2' + | otherwise = ev + -- ev': satisfy the precondition of can_eq_nc + + ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2' + + ; case mb_canon of { + + -- An IrredCt equality may be insoluble; but maybe not! + -- E.g. m a ~R# m b is not canonical, but may be + -- solved by a quantified constraint (T15290) + -- See Note [Looking up primitive equalities in quantified constraints] + Left irred_ct -> do { tryQCsIrredEqCt irred_ct + ; solveIrred irred_ct } ; + + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_ct + ; tryQCsEqCt eq_ct + ; simpleStage (updInertEqs eq_ct) + ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } } + +updInertEqs :: EqCt -> TcS () +updInertEqs eq_ct + = do { kickOutRewritable (KOAfterAdding (eqCtLHS eq_ct)) (eqCtFlavourRole eq_ct) + ; tc_lvl <- getTcLevel + ; updInertCans (addEqToCans tc_lvl eq_ct) } + + +{- ********************************************************************* +* * +* zonkEqTypes +* * +********************************************************************* -} + +--------------------------------- +-- | Compare types for equality, while zonking as necessary. Gives up +-- as soon as it finds that two types are not equal. +-- This is quite handy when some unification has made two +-- types in an inert Wanted to be equal. We can discover the equality without +-- rewriting, which is sometimes very expensive (in the case of type functions). +-- In particular, this function makes a ~20% improvement in test case +-- perf/compiler/T5030. +-- +-- Returns either the (partially zonked) types in the case of +-- inequality, or the one type in the case of equality. canEqReflexive is +-- a good next step in the 'Right' case. Returning 'Left' is always safe. +-- +-- NB: This does *not* look through type synonyms. In fact, it treats type +-- synonyms as rigid constructors. In the future, it might be convenient +-- to look at only those arguments of type synonyms that actually appear +-- in the synonym RHS. But we're not there yet. +zonkEqTypes :: CtEvidence -> EqRel -> TcType -> TcType -> SolverStage (Pair TcType) +zonkEqTypes ev eq_rel ty1 ty2 + = Stage $ do { res <- go ty1 ty2 + ; case res of + Left pair -> continueWith pair + Right ty -> canEqReflexive ev eq_rel ty } + where + go :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) + go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 + go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 + go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 + + -- We handle FunTys explicitly here despite the fact that they could also be + -- treated as an application. Why? Well, for one it's cheaper to just look + -- at two types (the argument and result types) than four (the argument, + -- result, and their RuntimeReps). Also, we haven't completely zonked yet, + -- so we may run into an unzonked type variable while trying to compute the + -- RuntimeReps of the argument and result types. This can be observed in + -- testcase tc269. + go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2) + | af1 == af2 + , eqType w1 w2 + = do { res_a <- go arg1 arg2 + ; res_b <- go res1 res2 + ; return $ combine_rev (FunTy af1 w1) res_b res_a } + + go ty1@(FunTy {}) ty2 = bale_out ty1 ty2 + go ty1 ty2@(FunTy {}) = bale_out ty1 ty2 + + go ty1 ty2 + | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1 + , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2 + = if tc1 == tc2 && tys1 `equalLength` tys2 + -- Crucial to check for equal-length args, because + -- we cannot assume that the two args to 'go' have + -- the same kind. E.g go (Proxy * (Maybe Int)) + -- (Proxy (*->*) Maybe) + -- We'll call (go (Maybe Int) Maybe) + -- See #13083 + then tycon tc1 tys1 tys2 + else bale_out ty1 ty2 + + go ty1 ty2 + | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + = do { res_a <- go ty1a ty2a + ; res_b <- go ty1b ty2b + ; return $ combine_rev mkAppTy res_b res_a } + + go ty1@(LitTy lit1) (LitTy lit2) + | lit1 == lit2 + = return (Right ty1) + + go ty1 ty2 = bale_out ty1 ty2 + -- We don't handle more complex forms here + + bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) + + tyvar :: SwapFlag -> TcTyVar -> TcType + -> TcS (Either (Pair TcType) TcType) + -- Try to do as little as possible, as anything we do here is redundant + -- with rewriting. In particular, no need to zonk kinds. That's why + -- we don't use the already-defined zonking functions + tyvar swapped tv ty + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> give_up + Indirect ty' -> do { trace_indirect tv ty' + ; unSwap swapped go ty' ty } } + _ -> give_up + where + give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty + + tyvar_tyvar tv1 tv2 + | tv1 == tv2 = return (Right (mkTyVarTy tv1)) + | otherwise = do { (ty1', progress1) <- quick_zonk tv1 + ; (ty2', progress2) <- quick_zonk tv2 + ; if progress1 || progress2 + then go ty1' ty2' + else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } + + trace_indirect tv ty + = traceTcS "Following filled tyvar (zonk_eq_types)" + (ppr tv <+> equals <+> ppr ty) + + quick_zonk tv = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> return (TyVarTy tv, False) + Indirect ty' -> do { trace_indirect tv ty' + ; return (ty', True) } } + _ -> return (TyVarTy tv, False) + + -- This happens for type families, too. But recall that failure + -- here just means to try harder, so it's OK if the type function + -- isn't injective. + tycon :: TyCon -> [TcType] -> [TcType] + -> TcS (Either (Pair TcType) TcType) + tycon tc tys1 tys2 + = do { results <- zipWithM go tys1 tys2 + ; return $ case combine_results results of + Left tys -> Left (mkTyConApp tc <$> tys) + Right tys -> Right (mkTyConApp tc tys) } + + combine_results :: [Either (Pair TcType) TcType] + -> Either (Pair [TcType]) [TcType] + combine_results = bimap (fmap reverse) reverse . + foldl' (combine_rev (:)) (Right []) + + -- combine (in reverse) a new result onto an already-combined result + combine_rev :: (a -> b -> c) + -> Either (Pair b) b + -> Either (Pair a) a + -> Either (Pair c) c + combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) + combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) + combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) + combine_rev f (Right tys) (Right ty) = Right (f ty tys) + + +{- ********************************************************************* +* * +* canonicaliseEquality +* * +********************************************************************* -} + +canonicaliseEquality + :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> SolverStage (Either IrredCt EqCt) +-- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2), +-- without zonking +-- This precondition is needed (only in DEBUG) to satisfy the assertions +-- in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy + +canonicaliseEquality ev eq_rel ty1 ty2 + = Stage $ do { traceTcS "canonicaliseEquality" $ + vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ty2 ] + ; rdr_env <- getGlobalRdrEnvTcS + ; fam_insts <- getFamInstEnvs + ; can_eq_nc False rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 } + +can_eq_nc + :: Bool -- True => both input types are rewritten + -> GlobalRdrEnv -- needed to see which newtypes are in scope + -> FamInstEnvs -- needed to unwrap data instances + -> CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue (Either IrredCt EqCt)) + +-- See Note [Comparing nullary type synonyms] in GHC.Core.Type. +can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2 + | tc1 == tc2 + = canEqReflexive ev eq_rel ty1 + +-- Expand synonyms first; see Note [Type synonyms and canonicalization] +can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 + +-- need to check for reflexivity in the ReprEq case. +-- See Note [Eager reflexivity check] +-- Check only when rewritten because the zonk_eq_types check in canEqNC takes +-- care of the non-rewritten case. +can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _ + | ty1 `tcEqType` ty2 + = canEqReflexive ev ReprEq ty1 + +-- When working with ReprEq, unwrap newtypes. +-- See Note [Unwrap newtypes first] +-- This must be above the TyVarTy case, in order to guarantee (TyEq:N) +can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | ReprEq <- eq_rel + , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 + = can_eq_newtype_nc rdr_env envs ev NotSwapped ty1 stuff1 ty2 ps_ty2 + + | ReprEq <- eq_rel + , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 + = can_eq_newtype_nc rdr_env envs ev IsSwapped ty2 stuff2 ty1 ps_ty1 + +-- Then, get rid of casts +can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 + | isNothing (canEqLHS_maybe ty2) -- See (EIK3) in Note [Equalities with incompatible kinds] + = canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 +can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ + | isNothing (canEqLHS_maybe ty1) -- See (EIK3) in Note [Equalities with incompatible kinds] + = canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 + +---------------------- +-- Otherwise try to decompose +---------------------- + +-- Literals +can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ + | l1 == l2 + = do { setEvBindIfWanted ev True (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1) + ; stopWith ev "Equal LitTy" } + +-- Decompose FunTy: (s -> t) and (c => t) +-- NB: don't decompose (Int -> blah) ~ (Show a => blah) +can_eq_nc _rewritten _rdr_env _envs ev eq_rel + (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1 + (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2 + | af1 == af2 -- See Note [Decomposing FunTy] + = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b) + +-- Decompose type constructor applications +-- NB: we have expanded type synonyms already +can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ + | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 + -- tcSplitTyConApp_maybe: we want to catch e.g. Maybe Int ~ (Int -> Int) + -- here for better error messages rather than decomposing into AppTys; + -- hence not using a direct match on TyConApp + + , not (isTypeFamilyTyCon tc1 || isTypeFamilyTyCon tc2) + -- A type family at the top of LHS or RHS: we want to fall through + -- to the canonical-LHS cases (look for canEqLHS_maybe) + + -- See (TC1) in Note [Canonicalising TyCon/TyCon equalities] + , let role = eqRelRole eq_rel + both_generative = isGenerativeTyCon tc1 role && isGenerativeTyCon tc2 role + , rewritten || both_generative + = canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2 + +can_eq_nc _rewritten _rdr_env _envs ev eq_rel + s1@ForAllTy{} _ + s2@ForAllTy{} _ + = can_eq_nc_forall ev eq_rel s1 s2 + +-- See Note [Canonicalising type applications] about why we require rewritten types +-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families +-- NB: Only decompose AppTy for nominal equality. +-- See Note [Decomposing AppTy equalities] +can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _ + | Just (t1, s1) <- tcSplitAppTy_maybe ty1 + , Just (t2, s2) <- tcSplitAppTy_maybe ty2 + = can_eq_app ev t1 s1 t2 s2 + +------------------- +-- Can't decompose. +------------------- + +-- No similarity in type structure detected. Rewrite and try again. +can_eq_nc False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 + = -- Rewrite the two types and try again + do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1 + ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2) + ; can_eq_nc True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } + +---------------------------- +-- Look for a canonical LHS. +-- Only rewritten types end up below here. +---------------------------- + +-- NB: pattern match on rewritten=True: we want only rewritten types sent to canEqLHS +-- This means we've rewritten any variables and reduced any type family redexes +-- See also Note [No top-level newtypes on RHS of representational equalities] + +can_eq_nc True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just can_eq_lhs1 <- canEqLHS_maybe ty1 + = do { traceTcS "can_eq1" (ppr ty1 $$ ppr ty2) + ; canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 } + + | Just can_eq_lhs2 <- canEqLHS_maybe ty2 + = do { traceTcS "can_eq2" (ppr ty1 $$ ppr ty2) + ; canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1 } + + -- If the type is TyConApp tc1 args1, then args1 really can't be less + -- than tyConArity tc1. It could be *more* than tyConArity, but then we + -- should have handled the case as an AppTy. That case only fires if + -- _both_ sides of the equality are AppTy-like... but if one side is + -- AppTy-like and the other isn't (and it also isn't a variable or + -- saturated type family application, both of which are handled by + -- can_eq_nc), we're in a failure mode and can just fall through. + +---------------------------- +-- Fall-through. Give up. +---------------------------- + +-- We've rewritten and the types don't match. Give up. +can_eq_nc True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 + = do { traceTcS "can_eq_nc catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) + ; case eq_rel of -- See Note [Unsolved equalities] + ReprEq -> finishCanWithIrred ReprEqReason ev + NomEq -> finishCanWithIrred ShapeMismatchReason ev } + -- No need to call canEqSoftFailure/canEqHardFailure because they + -- rewrite, and the types involved here are already rewritten + + +{- Note [Unsolved equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved equality like + (a b ~R# Int) +that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. +So we want to make it a potentially-soluble Irred not an insoluble one. +Missing this point is what caused #15431 +-} + +--------------------------------- +can_eq_nc_forall :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- (forall as. phi1) ~ (forall bs. phi2) +-- Check for length match of as, bs +-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] +-- But remember also to unify the kinds of as and bs +-- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] +-- Remember also that we might have forall z (a:z). blah +-- so we must proceed one binder at a time (#13879) + +can_eq_nc_forall ev eq_rel s1 s2 + | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev + = do { let free_tvs = tyCoVarsOfTypes [s1,s2] + (bndrs1, phi1) = tcSplitForAllTyVarBinders s1 + (bndrs2, phi2) = tcSplitForAllTyVarBinders s2 + flags1 = binderFlags bndrs1 + flags2 = binderFlags bndrs2 + ; if not (all2 eqForAllVis flags1 flags2) -- Note [ForAllTy and type equality] + then do { traceTcS "Forall failure" $ + vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 + , ppr flags1, ppr flags2 ] + ; canEqHardFailure ev s1 s2 } + else + do { traceTcS "Creating implication for polytype equality" $ ppr ev + ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs + ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ + binderVars bndrs1 + + ; let phi1' = substTy subst1 phi1 + + -- Unify the kinds, extend the substitution + go :: [TcTyVar] -> Subst -> [TyVarBinder] + -> TcS (TcCoercion, Cts) + go (skol_tv:skol_tvs) subst (bndr2:bndrs2) + = do { let tv2 = binderVar bndr2 + ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv) + (substTy subst (tyVarKind tv2)) + ; let subst' = extendTvSubstAndInScope subst tv2 + (mkCastTy (mkTyVarTy skol_tv) kind_co) + -- skol_tv is already in the in-scope set, but the + -- free vars of kind_co are not; hence "...AndInScope" + ; (co, wanteds2) <- go skol_tvs subst' bndrs2 + ; return ( mkForAllCo skol_tv kind_co co + , wanteds1 `unionBags` wanteds2 ) } + + -- Done: unify phi1 ~ phi2 + go [] subst bndrs2 + = assert (null bndrs2) $ + unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) + + go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] + + empty_subst2 = mkEmptySubst (getSubstInScope subst1) + + ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ + go skol_tvs empty_subst2 bndrs2 + ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds + + ; setWantedEq orig_dest all_co + ; stopWith ev "Deferred polytype equality" } } + + | otherwise + = do { traceTcS "Omitting decomposition of given polytype equality" $ + pprEq s1 s2 -- See Note [Do not decompose Given polytype equalities] + ; stopWith ev "Discard given polytype equality" } + + where + unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) + -- This version returns the wanted constraint rather + -- than putting it in the work list + unify loc rewriters role ty1 ty2 + | ty1 `tcEqType` ty2 + = return (mkReflCo role ty1, emptyBag) + | otherwise + = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2 + ; return (co, unitBag (mkNonCanonical wanted)) } + + +{- Note [Unwrap newtypes first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Decomposing newtype equalities] + +Consider + newtype N m a = MkN (m a) +N will get a conservative, Nominal role for its second parameter 'a', +because it appears as an argument to the unknown 'm'. Now consider + [W] N Maybe a ~R# N Maybe b + +If we /decompose/, we'll get + [W] a ~N# b + +But if instead we /unwrap/ we'll get + [W] Maybe a ~R# Maybe b +which in turn gives us + [W] a ~R# b +which is easier to satisfy. + +Conclusion: we must unwrap newtypes before decomposing them. This happens +in `can_eq_newtype_nc` + +We did flirt with making the /rewriter/ expand newtypes, rather than +doing it in `can_eq_newtype_nc`. But with recursive newtypes we want +to be super-careful about expanding! + + newtype A = MkA [A] -- Recursive! + + f :: A -> [A] + f = coerce + +We have [W] A ~R# [A]. If we rewrite [A], it'll expand to + [[[[[...]]]]] +and blow the reduction stack. See Note [Newtypes can blow the stack] +in GHC.Tc.Solver.Rewrite. But if we expand only the /top level/ of +both sides, we get + [W] [A] ~R# [A] +which we can, just, solve by reflexivity. + +So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`. + +This is all very delicate. There is a real risk of a loop in the type checker +with recursive newtypes -- but I think we're doomed to do *something* +delicate, as we're really trying to solve for equirecursive type +equality. Bottom line for users: recursive newtypes do not play well with type +inference for representational equality. See also Section 5.3.1 and 5.3.4 of +"Safe Zero-cost Coercions for Haskell" (JFP 2016). + +See also Note [Decomposing newtype equalities]. + +--- Historical side note --- + +We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply; +see #22519. But that didn't work: see discussion in #22924. Specifically +we got a loop with a minor variation: + f2 :: a -> [A] + f2 = coerce + +Note [Eager reflexivity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + +and + + [W] X ~R X + +Naively, we would start unwrapping X and end up in a loop. Instead, +we do this eager reflexivity check. This is necessary only for representational +equality because the rewriter technology deals with the similar case +(recursive type families) for nominal equality. + +Note that this check does not catch all cases, but it will catch the cases +we're most worried about, types like X above that are actually inhabited. + +Here's another place where this reflexivity check is key: +Consider trying to prove (f a) ~R (f a). The AppTys in there can't +be decomposed, because representational equality isn't congruent with respect +to AppTy. So, when canonicalising the equality above, we get stuck and +would normally produce a CIrredCan. However, we really do want to +be able to solve (f a) ~R (f a). So, in the representational case only, +we do a reflexivity check. + +(This would be sound in the nominal case, but unnecessary, and I [Richard +E.] am worried that it would slow down the common case.) + + Note [Newtypes can blow the stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + newtype Y = MkY (Int -> Y) + +and now wish to prove + + [W] X ~R Y + +This Wanted will loop, expanding out the newtypes ever deeper looking +for a solid match or a solid discrepancy. Indeed, there is something +appropriate to this looping, because X and Y *do* have the same representation, +in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized +coercion will ever witness it. This loop won't actually cause GHC to hang, +though, because we check our depth in `can_eq_newtype_nc`. +-} + +------------------------ +-- | We're able to unwrap a newtype. Update the bits accordingly. +can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs + -> CtEvidence -- ^ :: ty1 ~ ty2 + -> SwapFlag + -> TcType -- ^ ty1 + -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' + -> TcType -- ^ ty2 + -> TcType -- ^ ty2, with type synonyms + -> TcS (StopOrContinue (Either IrredCt EqCt)) +can_eq_newtype_nc rdr_env envs ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 + = do { traceTcS "can_eq_newtype_nc" $ + vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ] + + -- Check for blowing our stack, and increase the depth + -- See Note [Newtypes can blow the stack] + ; let loc = ctEvLoc ev + ev' = ev `setCtEvLoc` bumpCtLocDepth loc + ; checkReductionDepth loc ty1 + + -- Next, we record uses of newtype constructors, since coercing + -- through newtypes is tantamount to using their constructors. + ; recordUsedGREs gres + + ; let redn1 = mkReduction co1 ty1' + + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped + redn1 (mkReflRedn Representational ps_ty2) + + ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 } + +--------- +-- ^ Decompose a type application. +-- All input types must be rewritten. See Note [Canonicalising type applications] +-- Nominal equality only! +can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 + -> Xi -> Xi -- s1 t1 + -> Xi -> Xi -- s2 t2 + -> TcS (StopOrContinue (Either IrredCt EqCt)) + +-- AppTys only decompose for nominal equality, so this case just leads +-- to an irreducible constraint; see typecheck/should_compile/T10494 +-- See Note [Decomposing AppTy equalities] +can_eq_app ev s1 t1 s2 t2 + | CtWanted { ctev_dest = dest } <- ev + = do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1 + , text "s2:" <+> ppr s2, text "t2:" <+> ppr t2 + , text "vis:" <+> ppr (isNextArgVisible s1) ]) + ; (co,_,_) <- wrapUnifierTcS ev Nominal $ \uenv -> + -- Unify arguments t1/t2 before function s1/s2, because + -- the former have smaller kinds, and hence simpler error messages + -- c.f. GHC.Tc.Utils.Unify.uType (go_app) + do { let arg_env = updUEnvLoc uenv (adjustCtLoc (isNextArgVisible s1) False) + ; co_t <- uType arg_env t1 t2 + ; co_s <- uType uenv s1 s2 + ; return (mkAppCo co_s co_t) } + ; setWantedEq dest co + ; stopWith ev "Decomposed [W] AppTy" } + + -- If there is a ForAll/(->) mismatch, the use of the Left coercion + -- below is ill-typed, potentially leading to a panic in splitTyConApp + -- Test case: typecheck/should_run/Typeable1 + -- We could also include this mismatch check above (for W and D), but it's slow + -- and we'll get a better error message not doing it + | s1k `mismatches` s2k + = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) + + | CtGiven { ctev_evar = evar } <- ev + = do { let co = mkCoVarCo evar + co_s = mkLRCo CLeft co + co_t = mkLRCo CRight co + ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 + , evCoercion co_s ) + ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 + , evCoercion co_t ) + ; emitWorkNC [evar_t] + ; startAgainWith (mkNonCanonical evar_s) } + + where + loc = ctEvLoc ev + + s1k = typeKind s1 + s2k = typeKind s2 + + k1 `mismatches` k2 + = isForAllTy k1 && not (isForAllTy k2) + || not (isForAllTy k1) && isForAllTy k2 + +----------------------- +-- | Break apart an equality over a casted type +-- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) +canEqCast :: Bool -- are both types rewritten? + -> GlobalRdrEnv -> FamInstEnvs + -> CtEvidence + -> EqRel + -> SwapFlag + -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 + -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCast rewritten rdr_env envs ev eq_rel swapped ty1 co1 ty2 ps_ty2 + = do { traceTcS "Decomposing cast" (vcat [ ppr ev + , ppr ty1 <+> text "|>" <+> ppr co1 + , ppr ps_ty2 ]) + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkGReflLeftRedn role ty1 co1) + (mkReflRedn role ps_ty2) + ; can_eq_nc rewritten rdr_env envs new_ev eq_rel ty1 ty1 ty2 ps_ty2 } + where + role = eqRelRole eq_rel + +------------------------ +canTyConApp :: CtEvidence -> EqRel + -> Bool -- Both TyCons are generative + -> TyCon -> [TcType] + -> TyCon -> [TcType] + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- See Note [Decomposing TyConApp equalities] +-- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family +-- But they can be data families. +canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2 + | tc1 == tc2 + , tys1 `equalLength` tys2 + = do { inerts <- getInertSet + ; if can_decompose inerts + then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 + else canEqSoftFailure ev eq_rel ty1 ty2 } + + -- See Note [Skolem abstract data] in GHC.Core.Tycon + | tyConSkolem tc1 || tyConSkolem tc2 + = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) + ; finishCanWithIrred AbstractTyConReason ev } + + | otherwise -- Different TyCons + = if both_generative -- See (TC2) and (TC3) in + -- Note [Canonicalising TyCon/TyCon equalities] + then canEqHardFailure ev ty1 ty2 + else canEqSoftFailure ev eq_rel ty1 ty2 + where + -- Reconstruct the types for error messages. This would do + -- the wrong thing (from a pretty printing point of view) + -- for functions, because we've lost the FunTyFlag; but + -- in fact we never call canTyConApp on a saturated FunTyCon + ty1 = mkTyConApp tc1 tys1 + ty2 = mkTyConApp tc2 tys2 + + -- See Note [Decomposing TyConApp equalities] + -- and Note [Decomposing newtype equalities] + can_decompose inerts + = isInjectiveTyCon tc1 (eqRelRole eq_rel) + || (assert (eq_rel == ReprEq) $ + -- assert: isInjectiveTyCon is always True for Nominal except + -- for type synonyms/families, neither of which happen here + -- Moreover isInjectiveTyCon is True for Representational + -- for algebraic data types. So we are down to newtypes + -- and data families. + ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts) + -- See Note [Decomposing newtype equalities] (EX2) + +{- Note [Canonicalising TyCon/TyCon equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type family TF a where TF Char = Bool + data family DF a + newtype instance DF Bool = MkDF Int + +Suppose we are canonicalising [W] Int ~R# DF (TF a). Then + +(TC1) We might have an inert Given (a ~# Char), so if we rewrote the wanted + (i.e. went around again in `can_eq_nc` with `rewritten`=True, we'd get + [W] Int ~R# DF Bool + and then the `tcTopNormaliseNewTypeTF_maybe` call would fire and + we'd unwrap the newtype. So we must do that "go round again" bit. + Hence the complicated guard (rewritten || both_generative) in `can_eq_nc`. + +(TC2) If we can't rewrite `a` yet, we'll finish with an unsolved + [W] Int ~R# DF (TF a) + in the inert set. But we must use canEqSoftFailure, not canEqHardFailure, + because it might be solved "later" when we learn more about `a`. + Hence the use of `both_generative` in `canTyConApp`. + +(TC3) Here's another example: + [G] Age ~R# Int + where Age's constructor is not in scope. We don't want to report + an "inaccessible code" error in the context of this Given! So again + we want `canEqSoftFailure`. + + For example, see typecheck/should_compile/T10493, repeated here: + import Data.Ord (Down) -- no constructor + foo :: Coercible (Down Int) Int => Down Int -> Int + foo = coerce + + That should compile, but only because we use canEqSoftFailure and + not canEqHardFailure. + +Note [Fast path when decomposing TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (T s1 t1 ~ T s2 t2), then we can just decompose to + (s1 ~ s2, t1 ~ t2) +and push those back into the work list. But if + s1 = K k1 s2 = K k2 +then we will just decompose s1~s2, and it might be better to +do so on the spot. An important special case is where s1=s2, +and we get just Refl. + +So canDecomposableTyConAppOK uses wrapUnifierTcS etc to short-cut +that work. See also Note [Work-list ordering]. + +Note [Decomposing TyConApp equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + [G/W] T ty1 ~r T ty2 +Can we decompose it, and replace it by + [G/W] ty1 ~r' ty2 +and if so what role is r'? (In this Note, all the "~" are primitive +equalities "~#", but I have dropped the noisy "#" symbols.) Lots of +background in the paper "Safe zero-cost coercions for Haskell". + +This Note covers the topic for + * Datatypes + * Newtypes + * Data families +For the rest: + * Type synonyms: are always expanded + * Type families: see Note [Decomposing type family applications] + * AppTy: see Note [Decomposing AppTy equalities]. + +---- Roles of the decomposed constraints ---- +For a start, the role r' will always be defined like this: + * If r=N then r' = N + * If r=R then r' = role of T's first argument + +For example: + data TR a = MkTR a -- Role of T's first arg is Representational + data TN a = MkTN (F a) -- Role of T's first arg is Nominal + +The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument +role r' for a TyCon T at role r. E.g. + tyConRolesX Nominal TR = [Nominal] + tyConRolesX Representational TR = [Representational] + +---- Soundness and completeness ---- +For Givens, for /soundness/ of decomposition we need, forall ty1,ty2: + T ty1 ~r T ty2 ===> ty1 ~r' ty2 +Here "===>" means "implies". That is, given evidence for (co1 : T ty1 ~r T co2) +we can produce evidence for (co2 : ty1 ~r' ty2). But in the solver we +/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs +thereby. So for /completeness/ of decomposition we also need the reverse: + ty1 ~r' ty2 ===> T ty1 ~r T ty2 + +For Wanteds, for /soundness/ of decomposition we need: + ty1 ~r' ty2 ===> T ty1 ~r T ty2 +because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and +from that we want to derive evidence (T co2 : T ty1 ~r T ty2). +For /completeness/ of decomposition we need the reverse implication too, +else we may decompose to a new proof obligation that is stronger than +the one we started with. See Note [Decomposing newtype equalities]. + +---- Injectivity ---- +When do these bi-implications hold? In one direction it is easy. +We /always/ have + ty1 ~r' ty2 ===> T ty1 ~r T ty2 +This is the CO_TYCONAPP rule of the paper (Fig 5); see also the +TyConAppCo case of GHC.Core.Lint.lintCoercion. + +In the other direction, we have + T ty1 ~r T ty2 ==> ty1 ~r' ty2 if T is /injective at role r/ +This is the very /definition/ of injectivity: injectivity means result +is the same => arguments are the same, modulo the role shift. +See comments on GHC.Core.TyCon.isInjectiveTyCon. This is also +the CO_NTH rule in Fig 5 of the paper, except in the paper only +newtypes are non-injective at representation role, so the rule says "H +is not a newtype". + +Injectivity is a bit subtle: + Nominal Representational + Datatype YES YES + Newtype YES NO{1} + Data family YES NO{2} + +{1} Consider newtype N a = MkN (F a) -- Arg has Nominal role + Is it true that (N t1) ~R (N t2) ==> t1 ~N t2 ? + No, absolutely not. E.g. + type instance F Int = Int; type instance F Bool = Char + Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char! + + See Note [Decomposing newtype equalities] + +{2} We must treat data families precisely like newtypes, because of the + possibility of newtype instances. See also + Note [Decomposing newtype equalities]. See #10534 and + test case typecheck/should_fail/T10534. + +---- Takeaway summary ----- +For sound and complete decomposition, we simply need injectivity; +that is for isInjectiveTyCon to be true: + +* At Nominal role, isInjectiveTyCon is True for all the TyCons we are + considering in this Note: datatypes, newtypes, and data families. + +* For Givens, injectivity is necessary for soundness; completeness has no + side conditions. + +* For Wanteds, soundness has no side conditions; but injectivity is needed + for completeness. See Note [Decomposing newtype equalities] + +This is implemented in `can_decompose` in `canTyConApp`; it looks at +injectivity, just as specified above. + +Note [Work-list ordering] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider decomposing a TyCon equality + + (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k1) + +This gives rise to 2 equalities in the solver worklist + + (1) [W] k_fresh ~ k1 + (2) [W] t1::k_fresh ~ t2::k1 + +We would like to solve (1) before looking at (2), so that we don't end +up in the complexities of canEqLHSHetero. To do this: + +* `canDecomposableTyConAppOK` calls `uType` on the arguments + /left-to-right/. See the call to zipWith4M in that function. + +* `uType` keeps the bag of emitted constraints in the same + left-to-right order. See the use of `snocBag` in `uType_defer`. + +* `wrapUnifierTcS` adds the bag of deferred constraints from + `do_unifications` to the work-list using `extendWorkListEqs`. + +* `extendWorkListEqs` and `selectWorkItem` together arrange that the + list of constraints given to `extendWorkListEqs` is processed in + left-to-right order. + +This is not a very big deal. It reduces the number of solver steps +in the test RaeJobTalk from 1830 to 1815, a 1% reduction. But still, +it doesn't cost anything either. + +Note [Decomposing type family applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose we have + [G/W] (F ty1) ~r (F ty2) +This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2. + +We never decompose to + [G/W] ty1 ~r' ty2 + +Instead + +* For Givens we do nothing. Injective type families have no corresponding + evidence of their injectivity, so we cannot decompose an + injective-type-family Given. + +* For Wanteds, for the Nominal role only, we emit new Wanteds rather like + functional dependencies, for each injective argument position. + + E.g type family F a b -- injective in first arg, but not second + [W] (F s1 t1) ~N (F s2 t2) + Emit new Wanteds + [W] s1 ~N s2 + But retain the existing, unsolved constraint. + +Note [Decomposing newtype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note also applies to data families, which we treat like +newtype in case of 'newtype instance'. + +As Note [Decomposing TyConApp equalities] describes, if N is injective +at role r, we can do this decomposition? + [G/W] (N ty1) ~r (N ty2) to [G/W] ty1 ~r' ty2 + +For a Given with r=R, the answer is a solid NO: newtypes are not injective at +representational role, and we must not decompose, or we lose soundness. +Example is wrinkle {1} in Note [Decomposing TyConApp equalities]. + +For a Wanted with r=R, since newtypes are not injective at representational +role, decomposition is sound, but we may lose completeness. Nevertheless, +if the newtype is abstract (so can't be unwrapped) we can only solve +the equality by (a) using a Given or (b) decomposition. If (a) is impossible +(e.g. no Givens) then (b) is safe albeit potentially incomplete. + +There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete: + +* Incompleteness example (EX1): unwrap first + newtype Nt a = MkNt (Id a) + type family Id a where Id a = a + + [W] Nt Int ~R Nt Age + + Because of its use of a type family, Nt's parameter will get inferred to + have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, + which is unsatisfiable. Unwrapping, though, leads to a solution. + + Conclusion: always unwrap newtypes before attempting to decompose + them. This is done in can_eq_nc. Of course, we can't unwrap if the data + constructor isn't in scope. See Note [Unwrap newtypes first]. + +* Incompleteness example (EX2): available Givens + newtype Nt a = Mk Bool -- NB: a is not used in the RHS, + type role Nt representational -- but the user gives it an R role anyway + + [G] Nt t1 ~R Nt t2 + [W] Nt alpha ~R Nt beta + + We *don't* want to decompose to [W] alpha ~R beta, because it's possible + that alpha and beta aren't representationally equal. And if we figure + out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted + from the Given. This is somewhat similar to the question of overlapping + Givens for class constraints: see Note [Instance and Given overlap] in + GHC.Tc.Solver.Dict. + + Conclusion: don't decompose [W] N s ~R N t, if there are any Given + equalities that could later solve it. + + But what precisely does it mean to say "any Given equalities that could + later solve it"? + + In #22924 we had + [G] f a ~R# a [W] Const (f a) a ~R# Const a a + where Const is an abstract newtype. If we decomposed the newtype, we + could solve. Not-decomposing on the grounds that (f a ~R# a) might turn + into (Const (f a) a ~R# Const a a) seems a bit silly. + + In #22331 we had + [G] N a ~R# N b [W] N b ~R# N a + (where N is abstract so we can't unwrap). Here we really /don't/ want to + decompose, because the /only/ way to solve the Wanted is from that Given + (with a Sym). + + In #22519 we had + [G] a <= b [W] IO Age ~R# IO Int + + (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=) + is a type-level comparison on Nats). Here we /must/ decompose, despite the + existence of an Irred Given, or we will simply be stuck. (Side note: We + flirted with deep-rewriting of newtypes (see discussion on #22519 and + !9623) but that turned out not to solve #22924, and also makes type + inference loop more often on recursive newtypes.) + + The currently-implemented compromise is this: + + we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t' + + that is, a Given Irred equality with both sides headed with N. + See the call to noGivenNewtypeReprEqs in canTyConApp. + + This is not perfect. In principle a Given like [G] (a b) ~ (c d), or + even just [G] c, could later turn into N s ~ N t. But since the free + vars of a Given are skolems, or at least untouchable unification + variables, this is extremely unlikely to happen. + + Another worry: there could, just, be a CDictCan with some + un-expanded equality superclasses; but only in some very obscure + recursive-superclass situations. + + Yet another approach (!) is desribed in + Note [Decomposing newtypes a bit more aggressively]. + +Remember: decomposing Wanteds is always /sound/. This Note is +only about /completeness/. + +Note [Decomposing newtypes a bit more aggressively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IMPORTANT: the ideas in this Note are *not* implemented. Instead, the +current approach is detailed in Note [Decomposing newtype equalities] +and Note [Unwrap newtypes first]. +For more details about the ideas in this Note see + * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549 + * issue #22441 + * discussion on !9282. + +Consider [G] c, [W] (IO Int) ~R (IO Age) +where IO is abstract, and + newtype Age = MkAge Int -- Not abstract +With the above rules, if there any Given Irreds, +the Wanted is insoluble because we can't decompose it. But in fact, +if we look at the defn of IO, roughly, + newtype IO a = State# -> (State#, a) +we can see that decomposing [W] (IO Int) ~R (IO Age) to + [W] Int ~R Age +definitely does not lose completeness. Why not? Because the role of +IO's argment is representational. Hence: + + DecomposeNewtypeIdea: + decompose [W] (N s1 .. sn) ~R (N t1 .. tn) + if the roles of all N's arguments are representational + +If N's arguments really /are/ representational this will not lose +completeness. Here "really are representational" means "if you expand +all newtypes in N's RHS, we'd infer a representational role for each +of N's type variables in that expansion". See Note [Role inference] +in GHC.Tc.TyCl.Utils. + +But the user might /override/ a phantom role with an explicit role +annotation, and then we could (obscurely) get incompleteness. +Consider + + module A( silly, T ) where + newtype T a = MkT Int + type role T representational -- Override phantom role + + silly :: Coercion (T Int) (T Bool) + silly = Coercion -- Typechecks by unwrapping the newtype + + data Coercion a b where -- Actually defined in Data.Type.Coercion + Coercion :: Coercible a b => Coercion a b + + module B where + import A + f :: T Int -> T Bool + f = case silly of Coercion -> coerce + +Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose, +we'll get stuck with (Int ~R Bool). Instead we want to use the +[G] (T Int) ~R (T Bool), which will be in the Irreds. + +Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very +obscure incompleteness (above). But no one is reporting a problem from +the lack of decompostion, so we'll just leave it for now. This long +Note is just to record the thinking for our future selves. + +Note [Decomposing AppTy equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For AppTy all the same questions arise as in +Note [Decomposing TyConApp equalities]. We have + + s1 ~r s2, t1 ~N t2 ==> s1 t1 ~r s2 t2 (rule CO_APP) + s1 t1 ~N s2 t2 ==> s1 ~N s2, t1 ~N t2 (CO_LEFT, CO_RIGHT) + +In the first of these, why do we need Nominal equality in (t1 ~N t2)? +See {2} below. + +For sound and complete solving, we need both directions to decompose. So: +* At nominal role, all is well: we have both directions. +* At representational role, decomposition of Givens is unsound (see {1} below), + and decomposition of Wanteds is incomplete. + +Here is an example of the incompleteness for Wanteds: + + [G] g1 :: a ~R b + [W] w1 :: Maybe b ~R alpha a + [W] w2 :: alpha ~N Maybe + +Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get + + w1 := AppCo w3 w4 + [W] w3 :: Maybe ~R alpha + [W] w4 :: b ~N a + +Note that w4 is *nominal*. A nominal role here is necessary because AppCo +requires a nominal role on its second argument. (See {2} for an example of +why.) Now we are stuck, because w4 is insoluble. On the other hand, if we +see w2 first, setting alpha := Maybe, all is well, as we can decompose +Maybe b ~R Maybe a into b ~R a. + +Another example: + newtype Phant x = MkPhant Int + [W] w1 :: Phant Int ~R alpha Bool + [W] w2 :: alpha ~ Phant + +If we see w1 first, decomposing would be disastrous, as we would then try +to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become + [W] w1' :: Phant Int ~R Phant Bool + +which can then (assuming MkPhant is in scope) be simplified to Int ~R Int, +and all will be well. See also Note [Unwrap newtypes first]. + +Bottom line: +* Always decompose AppTy at nominal role: can_eq_app +* Never decompose AppTy at representational role (neither Given nor Wanted): + the lack of an equation in can_eq_nc + +Extra points +{1} Decomposing a Given AppTy over a representational role is simply + unsound. For example, if we have co1 :: Phant Int ~R a Bool (for + the newtype Phant, above), then we surely don't want any relationship + between Int and Bool, lest we also have co2 :: Phant ~ a around. + +{2} The role on the AppCo coercion is a conservative choice, because we don't + know the role signature of the function. For example, let's assume we could + have a representational role on the second argument of AppCo. Then, consider + + data G a where -- G will have a nominal role, as G is a GADT + MkG :: G Int + newtype Age = MkAge Int + + co1 :: G ~R a -- by assumption + co2 :: Age ~R Int -- by newtype axiom + co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo + + and now co3 can be used to cast MkG to have type G Age, in violation of + the way GADTs are supposed to work (which is to use nominal equality). +-} + +canDecomposableTyConAppOK :: CtEvidence -> EqRel + -> TyCon -> [TcType] -> [TcType] + -> TcS (StopOrContinue a) +-- Precondition: tys1 and tys2 are the same finite length, hence "OK" +canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 + = assert (tys1 `equalLength` tys2) $ + do { traceTcS "canDecomposableTyConAppOK" + (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) + ; case ev of + CtWanted { ctev_dest = dest } + -- new_locs and tc_roles are both infinite, so we are + -- guaranteed that cos has the same length as tys1 and tys2 + -- See Note [Fast path when decomposing TyConApps] + -> do { (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> + do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2 + -- zipWith4M: see Note [Work-list ordering] + -- in GHC.Tc.Solved.Equality + ; return (mkTyConAppCo role tc cos) } + ; setWantedEq dest co } + + CtGiven { ctev_evar = evar } + | let ev_co = mkCoVarCo evar + -> emitNewGivens loc + [ (r, ty1, ty2, mkSelCo (SelTyCon i r) ev_co) + | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] + , r /= Phantom + , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + + u_arg uenv arg_loc arg_role = uType arg_env + where + arg_env = uenv `setUEnvRole` arg_role + `updUEnvLoc` const arg_loc + + -- Infinite, to allow for over-saturated TyConApps + tc_roles = tyConRoleListX role tc + + -- Add nuances to the location during decomposition: + -- * if the argument is a kind argument, remember this, so that error + -- messages say "kind", not "type". This is determined based on whether + -- the corresponding tyConBinder is named (that is, dependent) + -- * if the argument is invisible, note this as well, again by + -- looking at the corresponding binder + -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't + -- do either of these changes. (Forgetting to do so led to #16188) + -- + -- NB: infinite in length + new_locs = [ adjustCtLocTyConBinder bndr loc + | bndr <- tyConBinders tc ] + ++ repeat loc + +canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag + -> (Type,Type,Type) -- (multiplicity,arg,res) + -> (Type,Type,Type) -- (multiplicity,arg,res) + -> TcS (StopOrContinue a) +canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2) + = do { traceTcS "canDecomposableFunTy" + (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) + ; case ev of + CtWanted { ctev_dest = dest } + -> do { (co, _, _) <- wrapUnifierTcS ev Nominal $ \ uenv -> + do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc + `setUEnvRole` funRole role SelMult + ; mult <- uType mult_env m1 m2 + ; arg <- uType (uenv `setUEnvRole` funRole role SelArg) a1 a2 + ; res <- uType (uenv `setUEnvRole` funRole role SelRes) r1 r2 + ; return (mkNakedFunCo role af mult arg res) } + ; setWantedEq dest co } + + CtGiven { ctev_evar = evar } + | let ev_co = mkCoVarCo evar + -> emitNewGivens loc + [ (funRole role fs, ty1, ty2, mkSelCo (SelFun fs) ev_co) + | (fs, ty1, ty2) <- [ (SelMult, m1, m2) + , (SelArg, a1, a2) + , (SelRes, r1, r2)] ] + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + +-- | Call canEqSoftFailure when canonicalizing an equality fails, but if the +-- equality is representational, there is some hope for the future. +canEqSoftFailure :: CtEvidence -> EqRel -> TcType -> TcType + -> TcS (StopOrContinue (Either IrredCt a)) +canEqSoftFailure ev NomEq ty1 ty2 + = canEqHardFailure ev ty1 ty2 +canEqSoftFailure ev ReprEq ty1 ty2 + = do { (redn1, rewriters1) <- rewrite ev ty1 + ; (redn2, rewriters2) <- rewrite ev ty2 + -- We must rewrite the types before putting them in the + -- inert set, so that we are sure to kick them out when + -- new equalities become available + ; traceTcS "canEqSoftFailure with ReprEq" $ + vcat [ ppr ev, ppr redn1, ppr redn2 ] + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; finishCanWithIrred ReprEqReason new_ev } + +-- | Call when canonicalizing an equality fails with utterly no hope. +canEqHardFailure :: CtEvidence -> TcType -> TcType + -> TcS (StopOrContinue (Either IrredCt a)) +-- See Note [Make sure that insolubles are fully rewritten] +canEqHardFailure ev ty1 ty2 + = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) + ; (redn1, rewriters1) <- rewriteForErrors ev ty1 + ; (redn2, rewriters2) <- rewriteForErrors ev ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; finishCanWithIrred ShapeMismatchReason new_ev } + +{- +Note [Canonicalising type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (s1 t1) ~ ty2, how should we proceed? +The simple thing is to see if ty2 is of form (s2 t2), and +decompose. + +However, over-eager decomposition gives bad error messages +for things like + a b ~ Maybe c + e f ~ p -> q +Suppose (in the first example) we already know a~Array. Then if we +decompose the application eagerly, yielding + a ~ Maybe + b ~ c +we get an error "Can't match Array ~ Maybe", +but we'd prefer to get "Can't match Array b ~ Maybe c". + +So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of +replacing (a b) by (Array b), before using try_decompose_app to +decompose it. + +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. +And if we don't do this there is a bad danger that +GHC.Tc.Solver.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose Given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like? So instead we simply discard +this given evidence. + +Note [No top-level newtypes on RHS of representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we're in this situation: + + work item: [W] c1 : a ~R b + inert: [G] c2 : b ~R Id a + +where + newtype Id a = Id a + +We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten +and the Id newtype is unwrapped. This is assured by requiring only rewritten +types in canEqCanLHS *and* having the newtype-unwrapping check above +the tyvar check in can_eq_nc. + +Note that this only applies to saturated applications of newtype TyCons, as +we can't rewrite an unsaturated application. See for example T22310, where +we ended up with: + + newtype Compose f g a = ... + + [W] t[tau] ~# Compose Foo Bar + +Note [Put touchable variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #10009, a very nasty example: + + f :: (UnF (F b) ~ b) => F b -> () + + g :: forall a. (UnF (F a) ~ a) => a -> () + g _ = f (undefined :: F a) + +For g we get [G] g1 : UnF (F a) ~ a + [W] w1 : UnF (F beta) ~ beta + [W] w2 : F a ~ F beta + +g1 is canonical (CEqCan). It is oriented as above because a is not touchable. +See canEqTyVarFunEq. + +w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key +here. + +w2 is canonical. But which way should it be oriented? As written, we'll be +stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is +a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS +of w2. We'll thus lose. + +But if w2 is swapped around, to + + [W] w3 : F beta ~ F a + +then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then +rewrite w1 to + + [W] w4 : UnF (F a) ~ beta + +and then, using g1, to + + [W] w5 : a ~ beta + +at which point we can unify and go on to glory. (This rewriting actually +happens all at once, in the call to rewrite during canonicalisation.) + +But what about the new LHS makes it better? It mentions a variable (beta) +that can appear in a Wanted -- a touchable metavariable never appears +in a Given. On the other hand, the original LHS mentioned only variables +that appear in Givens. We thus choose to put variables that can appear +in Wanteds on the left. + +Ticket #12526 is another good example of this in action. + +-} + +--------------------- +canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- lhs: pretty lhs, already rewritten + -> TcType -> TcType -- rhs: already rewritten + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | k1 `tcEqType` k2 + = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + + | otherwise + = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2 + + where + k1 = canEqLHSKind lhs1 + k2 = typeKind xi2 + + +{- +Note [Kind Equality Orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in +practice it does not. See Note [Fundeps with instances, and equality +orientation] where this is discussed at length. As a rule of thumb: we keep +the newest unification variables on the left of the equality. See also +Note [Improvement orientation]. + +In particular, `canEqCanLHSHetero` produces the following constraint equalities + +[X] (xi1 :: ki1) ~ (xi2 :: ki2) + --> [X] kco :: ki1 ~ ki2 + [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1 + +Note that the types in the LHS of the new constraints are the ones that were on the LHS of +the original constraint. + +--- Historical note --- +We prevously used to flip the kco to avoid using a sym in the cast + +[X] (xi1 :: ki1) ~ (xi2 :: ki2) + --> [X] kco :: ki2 ~ ki1 + [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1 + +But this sent solver in an infinite loop (see #19415). +-- End of historical note -- +-} + +canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) + -- (or reversed if SwapFlag=IsSwapped) + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- xi1 + -> TcKind -- ki1 + -> TcType -> TcType -- xi2 + -> TcKind -- ki2 + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 +-- See Note [Equalities with incompatible kinds] +-- See Note [Kind Equality Orientation] + +-- NB: preserve left-to-right orientation!! See wrinkle (W2) in +-- Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict +-- NotSwapped: +-- ev :: (lhs1:ki1) ~r# (xi2:ki2) +-- kind_co :: k11 ~# ki2 -- Same orientiation as ev +-- type_ev :: lhs1 ~r# (xi2 |> sym kind_co) +-- Swapped +-- ev :: (xi2:ki2) ~r# (lhs1:ki1) +-- kind_co :: ki2 ~# ki1 -- Same orientiation as ev +-- type_ev :: (xi2 |> kind_co) ~r# lhs1 + + = do { (kind_co, rewriters, unifs_happened) <- mk_kind_eq -- :: ki1 ~N ki2 + ; if unifs_happened + -- Unifications happened, so start again to do the zonking + -- Otherwise we might put something in the inert set that isn't inert + then startAgainWith (mkNonCanonical ev) + else + do { let lhs_redn = mkReflRedn role ps_xi1 + rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co + mb_sym_kind_co = case swapped of + NotSwapped -> mkSymCo kind_co + IsSwapped -> kind_co + + ; traceTcS "Hetero equality gives rise to kind equality" + (ppr swapped $$ + ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) + ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn + + ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co + ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }} + + where + mk_kind_eq :: TcS (CoercionN, RewriterSet, Bool) + -- Returned kind_co has kind (k1 ~ k2) if NotSwapped, (k2 ~ k1) if Swapped + -- Returned Bool = True if unifications happened, so we should retry + mk_kind_eq = case ev of + CtGiven { ctev_evar = evar } + -> do { let kind_co = mkKindCo (mkCoVarCo evar) + pred_ty = unSwap swapped (mkNomPrimEqPred liftedTypeKind) ki1 ki2 + kind_loc = mkKindEqLoc xi1 xi2 (ctev_loc ev) + ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co) + ; emitWorkNC [kind_ev] + ; return (ctEvCoercion kind_ev, emptyRewriterSet, False) } + + CtWanted {} + -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv -> + let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2) + in unSwap swapped (uType uenv') ki1 ki2 + ; return (kind_co, rewriterSetFromCts cts, not (null unifs)) } + + xi1 = canEqLHSType lhs1 + role = eqRelRole eq_rel + +canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs + -- or, if swapped: rhs ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- lhs, pretty lhs + -> TcType -> TcType -- rhs, pretty rhs + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- Guaranteed that typeKind lhs == typeKind rhs +canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | (xi2', mco) <- split_cast_ty xi2 + , Just lhs2 <- canEqLHS_maybe xi2' + = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco + + | otherwise + = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 + + where + split_cast_ty (CastTy ty co) = (ty, MCo co) + split_cast_ty other = (other, MRefl) + +-- This function deals with the case that both LHS and RHS are potential +-- CanEqLHSs. +canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco) + -- or, if swapped: (rhs |> mco) ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- pretty lhs + -> CanEqLHS -- rhs + -> TcType -- pretty rhs + -> MCoercion -- :: kind(rhs) ~N kind(lhs) + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco + | lhs1 `eqCanEqLHS` lhs2 + -- It must be the case that mco is reflexive + = canEqReflexive ev eq_rel lhs1_ty + + | TyVarLHS tv1 <- lhs1 + , TyVarLHS tv2 <- lhs2 + = -- See Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify + do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) + ; if swapOverTyVars (isGiven ev) tv1 tv2 + then finish_with_swapping + else finish_without_swapping } + + | TyVarLHS {} <- lhs1 + , TyFamLHS {} <- lhs2 + = if put_tyvar_on_lhs + then finish_without_swapping + else finish_with_swapping + + | TyFamLHS {} <- lhs1 + , TyVarLHS {} <- lhs2 + = if put_tyvar_on_lhs + then finish_with_swapping + else finish_without_swapping + + | TyFamLHS fun_tc1 fun_args1 <- lhs1 + , TyFamLHS fun_tc2 fun_args2 <- lhs2 + -- See Note [Decomposing type family applications] + = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) + + ; unifications_done <- tryFamFamInjectivity ev eq_rel + fun_tc1 fun_args1 fun_tc2 fun_args2 mco + ; if unifications_done + then -- Go round again, since the unifications affect lhs/rhs + startAgainWith (mkNonCanonical ev) + else + do { tclvl <- getTcLevel + ; let tvs1 = tyCoVarsOfTypes fun_args1 + tvs2 = tyCoVarsOfTypes fun_args2 + + -- See Note [Orienting TyFamLHS/TyFamLHS] + swap_for_size = typesSize fun_args2 > typesSize fun_args1 + + -- See Note [Orienting TyFamLHS/TyFamLHS] + swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 && + -- See Note [Put touchable variables on the left] + not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1) + -- This second check is just to avoid unfruitful swapping + + ; if swap_for_rewriting || swap_for_size + then finish_with_swapping + else finish_without_swapping } } + where + sym_mco = mkSymMCo mco + role = eqRelRole eq_rel + lhs1_ty = canEqLHSType lhs1 + lhs2_ty = canEqLHSType lhs2 + + finish_without_swapping + = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) + + -- Swapping. We have ev : lhs1 ~ lhs2 |> co + -- We swap to new_ev : lhs2 ~ lhs1 |> sym co + -- ev = grefl1 ; sym new_ev ; grefl2 + -- where grefl1 : lhs1 ~ lhs1 |> sym co + -- grefl2 : lhs2 ~ lhs2 |> co + finish_with_swapping + = do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco + lhs2_redn = mkGReflLeftMRedn role lhs2_ty mco + ; new_ev <-rewriteEqEvidence emptyRewriterSet ev swapped lhs1_redn lhs2_redn + ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } + + put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq + -- See Note [Orienting TyVarLHS/TyFamLHS] + -- Same conditions as for canEqCanLHSFinish_try_unification + -- which we are setting ourselves up for here + +{- Note [Orienting TyVarLHS/TyFamLHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What if one side is a TyVarLHS and the other is a TyFamLHS, (a ~ F tys)? +Which to put on the left? Answer: + +* If there is no chance of unifying, put the type family on the left, + (F tys ~ a), because it's generally better to rewrite away function + calls. See `put_tyvar_on_lhs` in canEqCanLHS2; and + Note [Orienting TyVarLHS/TyFamLHS] + +* But if there /is/ a chance of unifying, put the tyvar on the left, + (a ~ F tys), as this may be our only shot to unify. Again see + `put_tyvar_on_lhs`. + +* But if we /fail/ to unify then flip back to (F tys ~ a) because it's + generally better to rewrite away function calls. See the call to + `swapAndFinish` in `canEqCanLHSFinish_try_unification` + + It's important to flip back. Consider + [W] F alpha ~ alpha + [W] F alpha ~ beta + [W] G alpha beta ~ Int ( where we have type instance G a a = a ) + If we end up with a stuck alpha ~ F alpha, we won't be able to solve this. + Test case: indexed-types/should_compile/CEqCanOccursCheck + +Note [Orienting TyFamLHS/TyFamLHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a TyFamLHS on both sides, we choose how to orient it. + +* swap_for_size. If we have + S a ~ F (G (H (Maybe a))) + then we swap so that we tend to rewrite the bigger type (F (G (H (Maybe a)))) + into the smaller one (S a). This same test tends to avoid occurs-check + errors. E.g. + S g ~ F (G (S g)) + Here (S g) occurs on the RHS, so this is not canonical. But if we swap it + around, it /is/ canonical + F (G (S g)) ~ S g + +* swap_for_rewriting: put touchable meta-tyvars on the left: + see Note [Put touchable variables on the left] +-} + +-- The RHS here is either not CanEqLHS, or it's one that we +-- want to rewrite the LHS to (as per e.g. swapOverTyVars) +canEqCanLHSFinish, canEqCanLHSFinish_try_unification, + canEqCanLHSFinish_no_unification + :: CtEvidence -- (lhs ~ rhs) or if swapped (rhs ~ lhs) + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs + -> TcType -- rhs + -> TcS (StopOrContinue (Either IrredCt EqCt)) + -- RHS is fully rewritten, but with type synonyms + -- preserved as much as possible + -- Guaranteed preconditions that + -- (TyEq:K) handled in canEqCanLHSHomo + -- (TyEq:N) checked in can_eq_nc + -- (TyEq:TV) handled in canEqCanLHS2 + +--------------------------- +canEqCanLHSFinish ev eq_rel swapped lhs rhs + = do { traceTcS "canEqCanLHSFinish" $ + vcat [ text "ev:" <+> ppr ev + , text "swapped:" <+> ppr swapped + , text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ] + + -- Assertion: (TyEq:K) is already satisfied + ; massert (canEqLHSKind lhs `eqType` typeKind rhs) + + -- Assertion: (TyEq:N) is already satisfied (if applicable) + ; assertPprM ty_eq_N_OK $ + vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied" + , text "rhs:" <+> ppr rhs ] + + ; canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs } + + where + -- This is about (TyEq:N): check that we don't have a saturated application + -- of a newtype TyCon at the top level of the RHS, if the constructor + -- of the newtype is in scope. + ty_eq_N_OK :: TcS Bool + ty_eq_N_OK + | ReprEq <- eq_rel + , Just (tc, tc_args) <- splitTyConApp_maybe rhs + , Just con <- newTyConDataCon_maybe tc + -- #22310: only a problem if the newtype TyCon is saturated. + , tc_args `lengthAtLeast` tyConArity tc + -- #21010: only a problem if the newtype constructor is in scope. + = do { rdr_env <- getGlobalRdrEnvTcS + ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con) + ; return $ not con_in_scope } + | otherwise + = return True + +----------------------- +canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs + -- Try unification; for Wanted, Nominal equalities with a meta-tyvar on the LHS + | isWanted ev -- See Note [Do not unify Givens] + , NomEq <- eq_rel -- See Note [Do not unify representational equalities] + , TyVarLHS tv <- lhs + = do { given_eq_lvl <- getInnermostGivenEqLevel + ; if not (touchabilityAndShapeTest given_eq_lvl tv rhs) + then if | Just can_rhs <- canTyFamEqLHS_maybe rhs + -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs + -- See Note [Orienting TyVarLHS/TyFamLHS] + + | otherwise + -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + else + + -- We have a touchable unification variable on the left + do { check_result <- checkTouchableTyVarEq ev tv rhs + ; case check_result of { + PuFail reason + | Just can_rhs <- canTyFamEqLHS_maybe rhs + -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs + -- Swap back: see Note [Orienting TyVarLHS/TyFamLHS] + + | reason `cterHasOnlyProblems` do_not_prevent_rewriting + -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + + | otherwise + -> tryIrredInstead reason ev eq_rel swapped lhs rhs ; + + PuOK _ rhs_redn -> + + -- Success: we can solve by unification + do { -- In the common case where rhs_redn is Refl, we don't need to rewrite + -- the evidence, even if swapped=IsSwapped. Suppose the original was + -- [W] co : Int ~ alpha + -- We unify alpha := Int, and set co := . No need to + -- swap to co = sym co' + -- co' = + new_ev <- if isReflCo (reductionCoercion rhs_redn) + then return ev + else rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn + + ; let tv_ty = mkTyVarTy tv + final_rhs = reductionReducedType rhs_redn + + ; traceTcS "Sneaky unification:" $ + vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs, + text "Coercion:" <+> pprEq tv_ty final_rhs, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind final_rhs) ] + + -- Update the unification variable itself + ; unifyTyVar tv final_rhs + + -- Provide Refl evidence for the constraint + -- Ignore 'swapped' because it's Refl! + ; setEvBindIfWanted new_ev True $ + evCoercion (mkNomReflCo final_rhs) + + -- Kick out any constraints that can now be rewritten + ; kickOutAfterUnification [tv] + + ; return (Stop new_ev (text "Solved by unification")) }}}} + + -- Otherwise unification is off the table + | otherwise + = canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + + where + -- Some problems prevent /unification/ but not /rewriting/ + -- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3] + -- we can't unify (skolem-escape); but it /is/ canonical, + -- and hence we /can/ use it for rewriting + -- Concrete-ness: alpha[conc] ~ b[sk] + -- We can use it to rewrite; we still have to solve the original + do_not_prevent_rewriting :: CheckTyEqResult + do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<> + cteProblem cteConcrete + +--------------------------- +-- Unification is off the table +canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + = do { -- Do checkTypeEq to guarantee (TyEq:OC), (TyEq:F) + -- Must do the occurs check even on tyvar/tyvar equalities, + -- in case have x ~ (y :: ..x...); this is #12593. + ; check_result <- checkTypeEq ev eq_rel lhs rhs + + ; let lhs_ty = canEqLHSType lhs + ; case check_result of + PuFail reason + + -- If we had F a ~ G (F a), which gives an occurs check, + -- then swap it to G (F a) ~ F a, which does not + -- However `swap_for_size` above will orient it with (G (F a)) on + -- the left anwyway, so the next four lines of code are redundant + -- I'm leaving them here in case they become relevant again +-- | TyFamLHS {} <- lhs +-- , Just can_rhs <- canTyFamEqLHS_maybe rhs +-- , reason `cterHasOnlyProblem` cteSolubleOccurs +-- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs +-- | otherwise + + -> tryIrredInstead reason ev eq_rel swapped lhs rhs + + PuOK _ rhs_redn + -> do { new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn (eqRelRole eq_rel) lhs_ty) + rhs_redn + + -- Important: even if the coercion is Refl, + -- * new_ev has reductionReducedType on the RHS + -- * eq_rhs is set to reductionReducedType + -- See Note [Forgetful synonyms in checkTyConApp] in GHC.Tc.Utils.Unify + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs + , eq_rhs = reductionReducedType rhs_redn } } } + +---------------------- +swapAndFinish :: CtEvidence -> EqRel -> SwapFlag + -> TcType -> CanEqLHS -- ty ~ F tys + -> TcS (StopOrContinue (Either unused EqCt)) +-- We have an equality alpha ~ F tys, that we can't unify e.g because 'tys' +-- mentions alpha, it would not be a canonical constraint as-is. +-- We want to flip it to (F tys ~ a), whereupon it is canonical +swapAndFinish ev eq_rel swapped lhs_ty can_rhs + = do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped) + (mkReflRedn role (canEqLHSType can_rhs)) + (mkReflRedn role lhs_ty) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = can_rhs, eq_rhs = lhs_ty } } + +---------------------- +tryIrredInstead :: CheckTyEqResult -> CtEvidence + -> EqRel -> SwapFlag -> CanEqLHS -> TcType + -> TcS (StopOrContinue (Either IrredCt unused)) +-- We have a non-canonical equality +-- We still swap it if 'swapped' says so, so that it is oriented +-- in the direction that the error-reporting machinery +-- expects it; e.g. (m ~ t m) rather than (t m ~ m) +-- This is not very important, and only affects error reporting. +tryIrredInstead reason ev eq_rel swapped lhs rhs + = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs) + ; let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; finishCanWithIrred (NonCanonicalReason reason) new_ev } + +finishCanWithIrred :: CtIrredReason -> CtEvidence + -> TcS (StopOrContinue (Either IrredCt a)) +finishCanWithIrred reason ev + = do { -- Abort fast if we have any insoluble Wanted constraints, + -- and the TcS abort-if-insoluble flag is on. + when (isInsolubleReason reason) tryEarlyAbortTcS + + ; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } } + +----------------------- +-- | Solve a reflexive equality constraint +canEqReflexive :: CtEvidence -- ty ~ ty + -> EqRel + -> TcType -- ty + -> TcS (StopOrContinue a) -- always Stop +canEqReflexive ev eq_rel ty + = do { setEvBindIfWanted ev True $ + evCoercion (mkReflCo (eqRelRole eq_rel) ty) + ; stopWith ev "Solved by reflexivity" } + +{- Note [Equalities with incompatible kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What do we do when we have an equality + + (tv :: k1) ~ (rhs :: k2) + +where k1 and k2 differ? Easy: we create a coercion that relates k1 and +k2 and use this to cast. To wit, from + + [X] (tv :: k1) ~ (rhs :: k2) + +(where [X] is [G] or [W]), we go to + + [X] co :: k1 ~ k2 + [X] (tv :: k1) ~ ((rhs |> sym co) :: k1) + +Wrinkles: + +(EIK1) When X is W, the new type-level wanted is effectively rewritten by the + kind-level one. We thus include the kind-level wanted in the RewriterSet + for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. + This is done in canEqCanLHSHetero. + +(EIK2) Suppose we have [W] (a::Type) ~ (b::Type->Type). The above rewrite will produce + [W] w : a ~ (b |> kw) + [W] kw : Type ~ (Type->Type) + + But we do /not/ want to regard `w` as canonical, and use it for rewriting + other constraints: `kw` is insoluble, and replacing something of kind + `Type` with something of kind `Type->Type` (even wrapped in an insouluble + cast) does not help, and doing so turns out to lead to much worse error + messages. (In particular, if 'a' is a unification variable, we might + unify, losing the tracking info that it depends on solving `kw`.) + + Conclusion: if a RHS contains a corecion hole arising from fixing a hetero-kinded + equality, treat the equality (`w` in this case) as non-canonical, so that + * It will not be used for unification + * It will not be used for rewriting + Instead, it lands in the inert_irreds in the inert set, awaiting solution of + that `kw`. + + (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets + solved. This is done in kickOutAfterFillingCoercionHole, which kicks out + all equalities whose RHS mentions the filled-in coercion hole. Note that + it looks for type family equalities, too, because of the use of unifyTest + in canEqTyVarFunEq. + + (EIK2b) What if the RHS mentions /other/ coercion holes? How can that happen? The + main way is like this. Assume F :: forall k. k -> Type + [W] kw : k ~ Type + [W] w : a ~ F k t + We can rewrite `w` with `kw` like this: + [W] w' : a ~ F Type (t |> kw) + The cast on the second argument of `F` is necessary to keep the appliation well-kinded. + There is nothing special here; no reason not treat w' as canonical, and use it for + rewriting. Indeed tests JuanLopez only typechecks if we do. So we'd like to treat + this kind of equality as canonical. + + Hence the ch_hetero_kind field in CoercionHole: it is True of constraints + created by `canEqCanLHSHetero` to fix up hetero-kinded equalities; and False otherwise: + + * An equality constraint is non-canonical if it mentions a hetero-kind + CoercionHole on the RHS. See the `hasCoercionHoleCo` test in GHC.Tc.Utils.checkCo. + + * Hetero-kind CoercionHoles are created when the parent's CtOrigin is + KindEqOrigin: see GHC.Tc.Utils.TcMType.newCoercionHole and friends. We + set this origin, via `mkKindLoc`, in `mk_kind_eq` in `canEqCanLHSHetero`. + +(EIK3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the + algorithm detailed here, producing [W] co :: k1 ~ k2, and adding + [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time + later, we solve co, and fill in co's coercion hole. This kicks out + the irreducible as described in (2). + + But now, during canonicalization, we see the cast and remove it, in + canEqCast. By the time we get into canEqCanLHS, the equality is + heterogeneous again, and the process repeats. + + To avoid this, we don't strip casts off a type if the other type in the + equality is a CanEqLHS (the scenario above can happen with a type + family, too. testcase: typecheck/should_compile/T13822). + + And this is an improvement regardless: because tyvars can, generally, + unify with casted types, there's no reason to go through the work of + stripping off the cast when the cast appears opposite a tyvar. This is + implemented in the cast case of can_eq_nc. + +Historical note: + +We used to do this via emitting a Derived kind equality and then parking +the heterogeneous equality as irreducible. But this new approach is much +more direct. And it doesn't produce duplicate Deriveds (as the old one did). + +Note [Type synonyms and canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat type synonym applications as xi types, that is, they do not +count as type function applications. However, we do need to be a bit +careful with type synonyms: like type functions they may not be +generative or injective. However, unlike type functions, they are +parametric, so there is no problem in expanding them whenever we see +them, since we do not need to know anything about their arguments in +order to expand them; this is what justifies not having to treat them +as specially as type function applications. The thing that causes +some subtleties is that we prefer to leave type synonym applications +*unexpanded* whenever possible, in order to generate better error +messages. + +If we encounter an equality constraint with type synonym applications +on both sides, or a type synonym application on one side and some sort +of type application on the other, we simply must expand out the type +synonyms in order to continue decomposing the equality constraint into +primitive equality constraints. For example, suppose we have + + type F a = [Int] + +and we encounter the equality + + F a ~ [b] + +In order to continue we must expand F a into [Int], giving us the +equality + + [Int] ~ [b] + +which we can then decompose into the more primitive equality +constraint + + Int ~ b. + +However, if we encounter an equality constraint with a type synonym +application on one side and a variable on the other side, we should +NOT (necessarily) expand the type synonym, since for the purpose of +good error messages we want to leave type synonyms unexpanded as much +as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. + +Note [Type equality cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this situation (from indexed-types/should_compile/GivenLoop): + + instance C (Maybe b) + *[G] a ~ Maybe (F a) + [W] C a + +or (typecheck/should_compile/T19682b): + + instance C (a -> b) + *[W] alpha ~ (Arg alpha -> Res alpha) + [W] C alpha + +or (typecheck/should_compile/T21515): + + type family Code a + *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ] + [W] Code a ~ '[ '[ alpha ] ] + +In order to solve the final Wanted, we must use the starred constraint +for rewriting. But note that all starred constraints have occurs-check failures, +and so we can't straightforwardly add these to the inert set and +use them for rewriting. (NB: A rigid type constructor is at the +top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar +cases.) + +The key idea is to replace the outermost type family applications in the RHS of +the starred constraints with a fresh variable, which we'll call a cycle-breaker +variable, or cbv. Then, relate the cbv back with the original type family +application via new equality constraints. Our situations thus become: + + instance C (Maybe b) + [G] a ~ Maybe cbv + [G] F a ~ cbv + [W] C a + +or + + instance C (a -> b) + [W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 + [W] C alpha + +or + + [G] Code a ~ '[ '[ cbv ] ] + [G] Head (Head (Code a)) ~ cbv + [W] Code a ~ '[ '[ alpha ] ] + +This transformation (creating the new types and emitting new equality +constraints) is done by the `FamAppBreaker` field of `TEFA_Break`, which +in turn lives in the `tef_fam_app` field of `TyEqFlags`. And that in +turn controls the behaviour of the workhorse: GHC.Tc.Utils.Unify.checkTyEqRhs. + +The details depend on whether we're working with a Given or a Wanted. + +Given +----- +We emit a new Given, [G] F a ~ cbv, equating the type family application +to our new cbv. This is actually done by `break_given` in +`GHC.Tc.Solver.Monad.checkTypeEq`. + +Note its orientation: The type family ends up on the left; see +Note [Orienting TyFamLHS/TyFamLHS]d. No special treatment for +CycleBreakerTvs is necessary. This scenario is now easily soluble, by using +the first Given to rewrite the Wanted, which can now be solved. + +(The first Given actually also rewrites the second one, giving +[G] F (Maybe cbv) ~ cbv, but this causes no trouble.) + +Of course, we don't want our fresh variables leaking into e.g. error +messages. So we fill in the metavariables with their original type family +applications after we're done running the solver (in nestImplicTcS and +runTcSWithEvBinds). This is done by `restoreTyVarCycles`, which uses the +`inert_cycle_breakers` field in InertSet, which contains the pairings +invented in `break_given`. + +That is, we transform + [G] g : lhs ~ ...(F lhs)... +to + [G] (Refl lhs) : F lhs ~ cbv -- CEqCan + [G] g : lhs ~ ...cbv... -- CEqCan + +Note that +* `cbv` is a fresh cycle breaker variable. +* `cbv` is a is a meta-tyvar, but it is completely untouchable. +* We track the cycle-breaker variables in inert_cycle_breakers in InertSet +* We eventually fill in the cycle-breakers, with `cbv := F lhs`. + No one else fills in CycleBreakerTvs! +* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know + this fill-in is ultimately going to happen. +* In `inert_cycle_breakers`, we remember the (cbv, F lhs) pair; that is, we + remember the /original/ type. The [G] F lhs ~ cbv constraint may be rewritten + by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we + still fill in with cbv := F lhs +* This fill-in is done when solving is complete, by restoreTyVarCycles + in nestImplicTcS and runTcSWithEvBinds. + +Wanted +------ +First, we do not cycle-break unless the LHS is a unifiable type variable +See Note [Don't cycle-break Wanteds when not unifying] in GHC.Tc.Solver.Monad. + +OK, so suppose the LHS is a unifiable type variable. The fresh cycle-breaker +variables here must actually be normal, touchable metavariables. That is, they +are TauTvs. Nothing at all unusual. Repeating the example from above, we have + + *[W] alpha ~ (Arg alpha -> Res alpha) + +and we turn this into + + *[W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 + +where cbv1 and cbv2 are fresh TauTvs. This is actually done by `break_wanted` +in `GHC.Tc.Solver.Monad.checkTouchableTyVarEq`. + +Why TauTvs? See [Why TauTvs] below. + +Critically, we emit the two new constraints (the last two above) +directly instead of calling wrapUnifierTcS. (Otherwise, we'd end up +unifying cbv1 and cbv2 immediately, achieving nothing.) Next, we +unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This +unification happens immediately following a successful call to +checkTouchableTyVarEq, in canEqCanLHSFinish_try_unification. + +Now, we're here (including further context from our original example, +from the top of the Note): + + instance C (a -> b) + [W] Arg (cbv1 -> cbv2) ~ cbv1 + [W] Res (cbv1 -> cbv2) ~ cbv2 + [W] C (cbv1 -> cbv2) + +The first two W constraints reduce to reflexivity and are discarded, +and the last is easily soluble. + +[Why TauTvs]: +Let's look at another example (typecheck/should_compile/T19682) where we need +to unify the cbvs: + + class (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + + type family SameShapeAs xs ys :: Constraint where + SameShapeAs '[] ys = (ys ~ '[]) + SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys)) + + type family AllEqF xs ys :: Constraint where + AllEqF '[] '[] = () + AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) + + [W] alpha ~ (Head alpha : Tail alpha) + [W] AllEqF '[Bool] alpha + +Without the logic detailed in this Note, we're stuck here, as AllEqF cannot +reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, +just as described above. We thus invent cbv1 and cbv2 and unify +alpha := cbv1 -> cbv2, yielding (after zonking) + + [W] Head (cbv1 : cbv2) ~ cbv1 + [W] Tail (cbv1 : cbv2) ~ cbv2 + [W] AllEqF '[Bool] (cbv1 : cbv2) + +The first two W constraints simplify to reflexivity and are discarded. +But the last reduces: + + [W] Bool ~ cbv1 + [W] AllEq '[] cbv2 + +The first of these is solved by unification: cbv1 := Bool. The second +is solved by the instance for AllEq to become + + [W] AllEqF '[] cbv2 + [W] SameShapeAs '[] cbv2 + +While the first of these is stuck, the second makes progress, to lead to + + [W] AllEqF '[] cbv2 + [W] cbv2 ~ '[] + +This second constraint is solved by unification: cbv2 := '[]. We now +have + + [W] AllEqF '[] '[] + +which reduces to + + [W] () + +which is trivially satisfiable. Hooray! + +Note that we need to unify the cbvs here; if we did not, there would be +no way to solve those constraints. That's why the cycle-breakers are +ordinary TauTvs. + +How all this is implemented +--------------------------- +We implement all this via the `TEFA_Break` constructor of `TyEqFamApp`, +itself stored in the `tef_fam_app` field of `TyEqFlags`, which controls +the behaviour of `GHC.Tc.Utils.Unify.checkTyEqRhs`. The `TEFA_Break` +stuff happens when `checkTyEqRhs` encounters a family application. + +We try the cycle-breaking trick: +* For Wanteds, when there is a touchable unification variable on the left +* For Givens, regardless of the LHS + +EXCEPT that, in both cases, as `GHC.Tc.Solver.Monad.mkTEFA_Break` shows, we +don't use this trick: + +* When the constraint we are looking at was itself created by cycle-breaking; + see Detail (7) below. + +* For representational equalities, as there is no concrete use case where it is + helpful (unlike for nominal equalities). + + Furthermore, because function applications can be CanEqLHSs, but newtype + applications cannot, the disparities between the cases are enough that it + would be effortful to expand the idea to representational equalities. A quick + attempt, with + data family N a b + f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b + f = coerce + failed with "Could not match 'b' with 'b'." Further work is held off + until when we have a concrete incentive to explore this dark corner. + +More details: + + (1) We don't look under foralls, at all, in `checkTyEqRhs`. There might be + a cyclic occurrence underneath, in a case like + [G] lhs ~ forall b. ... lhs .... + but it doesn't matter because we will classify the constraint as Irred, + so it will not be used for rewriting. + + Earlier versions required an extra, post-breaking, check. Skipping this + check causes typecheck/should_fail/GivenForallLoop and polykinds/T18451 to + loop. But now it is all simpler, with no need for a second check. + + (2) Historical Note: our goal here is to avoid loops in rewriting. We can thus + skip looking in coercions, as we don't rewrite in coercions in the + algorithm in GHC.Solver.Rewrite. This doesn't seem relevant any more. + We cycle break to make the constraint canonical. + + (3) As we cycle-break as described in this Note, we can build ill-kinded + types. For example, if we have Proxy (F a) b, where (b :: F a), then + replacing this with Proxy cbv b is ill-kinded. However, we will later + set cbv := F a, and so the zonked type will be well-kinded again. + The temporary ill-kinded type hurts no one, and avoiding this would + be quite painfully difficult. + + Specifically, this detail does not contravene the Purely Kinded Type Invariant + (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType). + The PKTI says that we can call typeKind on any type, without failure. + It would be violated if we, say, replaced a kind (a -> b) with a kind c, + because an arrow kind might be consulted in piResultTys. Here, we are + replacing one opaque type like (F a b c) with another, cbv (opaque in + that we never assume anything about its structure, like that it has a + result type or a RuntimeRep argument). + + (4) The evidence for the produced Givens is all just reflexive, because we + will eventually set the cycle-breaker variable to be the type family, and + then, after the zonk, all will be well. See also the notes at the end of + the Given section of this Note. + + (5) The implementation in `checkTyEqRhs` is efficient because it only replaces + a type family application with a type variable, if that particular + appplication is implicated in the occurs check. For example: + [W] alpha ~ Maybe (F alpha, G beta) + We'll end up calling GHC.Tc.Utils.Unify.checkFamApp + * On `F alpha`, which fail and calls the cycle-breaker in TEFA_Break + * On `G beta`, which succeeds no problem. + + However, we make no attempt to detect cases like a ~ (F a, F a) and use the + same tyvar to replace F a. The constraint solver will common them up later! + (Cf. Note [Flattening type-family applications when matching instances] in + GHC.Core.Unify, which goes to this extra effort.) However, this is really + a very small corner case. The investment to craft a clever, performant + solution seems unworthwhile. + + (6) We often get the predicate associated with a constraint from its evidence + with ctPred. We thus must not only make sure the generated CEqCan's fields + have the updated RHS type (that is, the one produced by replacing type + family applications with fresh variables), but we must also update the + evidence itself. This is done by the call to rewriteEqEvidence in + canEqCanLHSFinish. + + (7) We don't wish to apply this magic on the equalities created + by this very same process. Consider this, from + typecheck/should_compile/ContextStack2: + + type instance TF (a, b) = (TF a, TF b) + t :: (a ~ TF (a, Int)) => ... + + [G] a ~ TF (a, Int) + + The RHS reduces, so we get + + [G] a ~ (TF a, TF Int) + + We then break cycles, to get + + [G] g1 :: a ~ (cbv1, cbv2) + [G] g2 :: TF a ~ cbv1 + [G] g3 :: TF Int ~ cbv2 + + g1 gets added to the inert set, as written. But then g2 becomes + the work item. g1 rewrites g2 to become + + [G] TF (cbv1, cbv2) ~ cbv1 + + which then uses the type instance to become + + [G] (TF cbv1, TF cbv2) ~ cbv1 + + which looks remarkably like the Given we started with. If left unchecked, + this will end up breaking cycles again, looping ad infinitum (and + resulting in a context-stack reduction error, not an outright loop). The + solution is easy: don't break cycles on an equality generated by breaking + cycles. Instead, we mark this final Given as a CIrredCan with a + NonCanonicalReason with the soluble occurs-check bit set (only). + + We track these equalities by giving them a special CtOrigin, + CycleBreakerOrigin. This works for both Givens and Wanteds, as we need the + logic in the W case for e.g. typecheck/should_fail/T17139. Because this + logic needs to work for Wanteds, too, we cannot simply look for a + CycleBreakerTv on the left: Wanteds don't use them. + + +********************************************************************** +* * + Rewriting evidence +* * +********************************************************************** +-} + +rewriteEqEvidence :: RewriterSet -- New rewriters + -- See GHC.Tc.Types.Constraint + -- Note [Wanteds rewrite Wanteds] + -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) + -- or orhs ~ olhs (swapped) + -> SwapFlag + -> Reduction -- lhs_co :: olhs ~ nlhs + -> Reduction -- rhs_co :: orhs ~ nrhs + -> TcS CtEvidence -- Of type nlhs ~ nrhs +-- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs), +-- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): +-- If not swapped +-- g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co +-- If swapped +-- g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co +-- +-- For a wanted equality (Wanted w), we do the dual thing: +-- New w1 : nlhs ~ nrhs +-- If not swapped +-- w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co +-- If swapped +-- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co +-- +-- It's all a form of rewriteEvidence, specialised for equalities +rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) + | NotSwapped <- swapped + , isReflCo lhs_co -- See Note [Rewriting with Refl] + , isReflCo rhs_co + = return (setCtEvPredType old_ev new_pred) + + | CtGiven { ctev_evar = old_evar } <- old_ev + = do { let new_tm = evCoercion ( mkSymCo lhs_co + `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar) + `mkTransCo` rhs_co) + ; newGivenEvVar loc (new_pred, new_tm) } + + | CtWanted { ctev_dest = dest + , ctev_rewriters = rewriters } <- old_ev + , let rewriters' = rewriters S.<> new_rewriters + = do { (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRole old_ev) nlhs nrhs + ; let co = maybeSymCo swapped $ + lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co + ; setWantedEq dest co + ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev + , ppr nlhs + , ppr nrhs + , ppr co + , ppr new_rewriters ]) + ; return new_ev } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise + = panic "rewriteEvidence" +#endif + where + new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs + loc = ctEvLoc old_ev + +{- +********************************************************************** +* * + tryInertEqs +* * +********************************************************************** + +Note [Combining equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + Inert: g1 :: a ~ t + Work item: g2 :: a ~ t + +Then we can simply solve g2 from g1, thus g2 := g1. Easy! +But it's not so simple: + +* If t is a type variable, the equalties might be oriented differently: + e.g. (g1 :: a~b) and (g2 :: b~a) + So we look both ways round. Hence the SwapFlag result to + inertsCanDischarge. + +* We can only do g2 := g1 if g1 can discharge g2; that depends on + (a) the role and (b) the flavour. E.g. a representational equality + cannot discharge a nominal one; a Wanted cannot discharge a Given. + The predicate is eqCanRewriteFR. + +* Visibility. Suppose S :: forall k. k -> Type, and consider unifying + S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type) + From the first argument we get (Type ~ Type->Type); from the second + argument we get (a ~ b) which in turn gives (Type ~ Type->Type). + See typecheck/should_fail/T16204c. + + That first argument is invisible in the source program (aside from + visible type application), so we'd much prefer to get the error from + the second. We track visibility in the uo_visible field of a TypeEqOrigin. + We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters, + the partition on isVisibleOrigin). + + So when combining two otherwise-identical equalites, we want to + keep the visible one, and discharge the invisible one. Hence the + call to strictly_more_visible. +-} + +tryInertEqs :: EqCt -> SolverStage () +tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) + = Stage $ + do { inerts <- getInertCans + ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item + -> do { setEvBindIfWanted ev True $ + evCoercion (maybeSymCo swapped $ + downgradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) + ; stopWith ev "Solved from inert" } + + | otherwise + -> continueWith () } + +inertsCanDischarge :: InertCans -> EqCt + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag ) -- Whether we need mkSymCo +inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w + , eq_ev = ev_w, eq_eq_rel = eq_rel }) + | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i + , eq_eq_rel = eq_rel } + <- findEq inerts lhs_w + , rhs_i `tcEqType` rhs_w + , inert_beats_wanted ev_i eq_rel ] + = -- Inert: a ~ ty + -- Work item: a ~ ty + Just (ev_i, NotSwapped) + + | Just rhs_lhs <- canEqLHS_maybe rhs_w + , (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i + , eq_eq_rel = eq_rel } + <- findEq inerts rhs_lhs + , rhs_i `tcEqType` canEqLHSType lhs_w + , inert_beats_wanted ev_i eq_rel ] + = -- Inert: a ~ b + -- Work item: b ~ a + Just (ev_i, IsSwapped) + + where + loc_w = ctEvLoc ev_w + flav_w = ctEvFlavour ev_w + fr_w = (flav_w, eq_rel) + + inert_beats_wanted ev_i eq_rel + = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] + -- strictly_more_visible: see last bullet of Note [Combining equalities] + fr_i `eqCanRewriteFR` fr_w + && not ((loc_w `strictly_more_visible` ctEvLoc ev_i) + && (fr_w `eqCanRewriteFR` fr_i)) + where + fr_i = (ctEvFlavour ev_i, eq_rel) + + -- See Note [Combining equalities], final bullet + strictly_more_visible loc1 loc2 + = not (isVisibleOrigin (ctLocOrigin loc2)) && + isVisibleOrigin (ctLocOrigin loc1) + +inertsCanDischarge _ _ = Nothing + + + +{- Note [Do not unify Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GADT match + data T a where + T1 :: T Int + ... + + f x = case x of + T1 -> True + ... + +So we get f :: T alpha[1] -> beta[1] + x :: T alpha[1] +and from the T1 branch we get the implication + forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool + +Now, clearly we don't want to unify alpha:=Int! Yet at the moment we +process [G] alpha[1] ~ Int, we don't have any given-equalities in the +inert set, and hence there are no given equalities to make alpha untouchable. + +NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that +never happens: invariant (GivenInv) in Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. + +Simple solution: never unify in Givens! + +Note [Do not unify representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [W] alpha ~R# b +where alpha is touchable. Should we unify alpha := b? + +Certainly not! Unifying forces alpha and be to be the same; but they +only need to be representationally equal types. + +For example, we might have another constraint [W] alpha ~# N b +where + newtype N b = MkN b +and we want to get alpha := N b. + +See also #15144, which was caused by unifying a representational +equality. + +Note [Solve by unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we solve + alpha[n] ~ ty +by unification, there are two cases to consider + +* TouchableSameLevel: if the ambient level is 'n', then + we can simply update alpha := ty, and do nothing else + +* TouchableOuterLevel free_metas n: if the ambient level is greater than + 'n' (the level of alpha), in addition to setting alpha := ty we must + do two other things: + + 1. Promote all the free meta-vars of 'ty' to level n. After all, + alpha[n] is at level n, and so if we set, say, + alpha[n] := Maybe beta[m], + we must ensure that when unifying beta we do skolem-escape checks + etc relevant to level n. Simple way to do that: promote beta to + level n. + + 2. Set the Unification Level Flag to record that a level-n unification has + taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad + +NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion +would be a no-op, and setting the unification flag unnecessarily would just +make the solver iterate more often. (We don't need to iterate when unifying +at the ambient level because of the kick-out mechanism.) +-} + + +{-******************************************************************** +* * + Final wrap-up for equalities +* * +********************************************************************-} + +{- Note [Looking up primitive equalities in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For equalities (a ~# b) look up (a ~ b), and then do a superclass +selection. This avoids having to support quantified constraints whose +kind is not Constraint, such as (forall a. F a ~# b) + +See + * Note [Evidence for quantified constraints] in GHC.Core.Predicate + * Note [Equality superclasses in quantified constraints] + in GHC.Tc.Solver.Dict +-} + +-------------------- +tryQCsIrredEqCt :: IrredCt -> SolverStage () +tryQCsIrredEqCt irred@(IrredCt { ir_ev = ev }) + | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev) + = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2 + + | otherwise -- All the calls come from in this module, where we deal only with + -- equalities, so ctEvPred ev) must be an equality. Indeed, we could + -- pass eq_rel, t1, t2 as arguments, to avoid this can't-happen case, + -- but it's not a hot path, and this is simple and robust + = pprPanic "solveIrredEquality" (ppr ev) + +-------------------- +tryQCsEqCt :: EqCt -> SolverStage () +tryQCsEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel }) + = lookup_eq_in_qcis (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs + +-------------------- +lookup_eq_in_qcis :: Ct -> EqRel -> TcType -> TcType -> SolverStage () +-- The "final QCI check" checks to see if we have +-- [W] t1 ~# t2 +-- and a Given quantified contraint like (forall a b. blah => a ~ b) +-- Why? See Note [Looking up primitive equalities in quantified constraints] +-- See also GHC.Tc.Solver.Dict +-- Note [Equality superclasses in quantified constraints] +lookup_eq_in_qcis work_ct eq_rel lhs rhs + = Stage $ + do { ev_binds_var <- getTcEvBindsVar + ; ics <- getInertCans + ; if isWanted ev -- Never look up Givens in quantified constraints + && not (null (inert_insts ics)) -- Shortcut common case + && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications] + then try_for_qci + else continueWith () } + where + ev = ctEvidence work_ct + loc = ctEvLoc ev + role = eqRelRole eq_rel + + try_for_qci -- First try looking for (lhs ~ rhs) + | Just (cls, tys) <- boxEqPred eq_rel lhs rhs + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "lookup_irred_in_qcis:1" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> try_swapping } + | otherwise + = continueWith () + + try_swapping -- Now try looking for (rhs ~ lhs) (see #23333) + | Just (cls, tys) <- boxEqPred eq_rel rhs lhs + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "lookup_irred_in_qcis:2" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped + (mkReflRedn role rhs) (mkReflRedn role lhs) + ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } + _ -> do { traceTcS "lookup_irred_in_qcis:3" (ppr work_ct) + ; continueWith () }} + | otherwise + = continueWith () + + mk_eq_ev cls tys mk_ev evs + | sc_id : rest <- classSCSelIds cls -- Just one superclass for this + = assert (null rest) $ case (mk_ev evs) of + EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) + ev -> pprPanic "mk_eq_ev" (ppr ev) + | otherwise = pprPanic "finishEqCt" (ppr work_ct) + +{- Note [Instances in no-evidence implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #15290 we had + [G] forall p q. Coercible p q => Coercible (m p) (m q)) -- Quantified + [W] forall a. m (Int, IntStateT m a) + ~R# + m (Int, StateT Int m a) + +The Given is an ordinary quantified constraint; the Wanted is an implication +equality that arises from + [W] (forall a. t1) ~R# (forall a. t2) + +But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) +we can't generate any term evidence. So we can't actually use that +lovely quantified constraint. Alas! + +This test arranges to ignore the instance-based solution under these +(rare) circumstances. It's sad, but I really don't see what else we can do. +-} + + +{- +********************************************************************** +* * + Functional dependencies for type families +* * +********************************************************************** + +Note [Reverse order of fundep equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this scenario (from dependent/should_fail/T13135_simple): + + type Sig :: Type -> Type + data Sig a = SigFun a (Sig a) + + type SmartFun :: forall (t :: Type). Sig t -> Type + type family SmartFun sig = r | r -> sig where + SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig + + [W] SmartFun @kappa sigma ~ (Int -> Bool) + +The injectivity of SmartFun allows us to produce two new equalities: + + [W] w1 :: Type ~ kappa + [W] w2 :: SigFun @Type Int beta ~ sigma + +for some fresh (beta :: SigType). The second Wanted here is actually +heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. +Of course, if we solve the first wanted first, the second becomes homogeneous. + +When looking for injectivity-inspired equalities, we work left-to-right, +producing the two equalities in the order written above. However, these +equalities are then passed into wrapUnifierTcS, which will fail, adding these +to the work list. However, crucially, the work list operates like a *stack*. +So, because we add w1 and then w2, we process w2 first. This is silly: solving +w1 would unlock w2. So we make sure to add equalities to the work +list in left-to-right order, which requires a few key calls to 'reverse'. + +This treatment is also used for class-based functional dependencies, although +we do not have a program yet known to exhibit a loop there. It just seems +like the right thing to do. + +When this was originally conceived, it was necessary to avoid a loop in T13135. +That loop is now avoided by continuing with the kind equality (not the type +equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]). +However, the idea of working left-to-right still seems worthwhile, and so the calls +to 'reverse' remain. + +Note [Improvement orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation], which describes +the Exact Same Problem, with the same solution, but for functional dependencies. + +A very delicate point is the orientation of equalities +arising from injectivity improvement (#12522). Suppose we have + type family F x = t | t -> x + type instance F (a, Int) = (Int, G a) +where G is injective; and wanted constraints + + [W] TF (alpha, beta) ~ fuv + [W] fuv ~ (Int, ) + +The injectivity will give rise to constraints + + [W] gamma1 ~ alpha + [W] Int ~ beta + +The fresh unification variable gamma1 comes from the fact that we +can only do "partial improvement" here; see Section 5.2 of +"Injective type families for Haskell" (HS'15). + +Now, it's very important to orient the equations this way round, +so that the fresh unification variable will be eliminated in +favour of alpha. If we instead had + [W] alpha ~ gamma1 +then we would unify alpha := gamma1; and kick out the wanted +constraint. But when we grough it back in, it'd look like + [W] TF (gamma1, beta) ~ fuv +and exactly the same thing would happen again! Infinite loop. + +This all seems fragile, and it might seem more robust to avoid +introducing gamma1 in the first place, in the case where the +actual argument (alpha, beta) partly matches the improvement +template. But that's a bit tricky, esp when we remember that the +kinds much match too; so it's easier to let the normal machinery +handle it. Instead we are careful to orient the new +equality with the template on the left. Delicate, but it works. + +-} + +tryFamFamInjectivity :: CtEvidence -> EqRel + -> TyCon -> [TcType] -> TyCon -> [TcType] -> MCoercion + -> TcS Bool -- True <=> some unification happened +tryFamFamInjectivity ev eq_rel fun_tc1 fun_args1 fun_tc2 fun_args2 mco + | ReprEq <- eq_rel + = return False -- Injectivity applies only for Nominal equalities + | fun_tc1 /= fun_tc2 + = return False -- If the families don't match, stop. + | isGiven ev + = return False -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Dict + + -- So this is a [W] (F tys1 ~N# F tys2) + + -- Is F an injective type family + | Injective inj <- tyConInjectivityInfo fun_tc1 + = unifyFunDeps ev Nominal $ \uenv -> + uPairsTcM uenv [ Pair ty1 ty2 + | (ty1,ty2,True) <- zip3 fun_args1 fun_args2 inj ] + + -- Built-in synonym families don't have an entry point for this + -- use case. So, we just use sfInteractInert and pass two equal + -- RHSs. We *could* add another entry point, but then there would + -- be a burden to make sure the new entry point and existing ones + -- were internally consistent. This is slightly distasteful, but + -- it works well in practice and localises the problem. Ugh. + | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1 + = let tc_kind = tyConKind fun_tc1 + ki1 = piResultTys tc_kind fun_args1 + ki2 | MRefl <- mco + = ki1 -- just a small optimisation + | otherwise + = piResultTys tc_kind fun_args2 + + fake_rhs1 = anyTypeOfKind ki1 + fake_rhs2 = anyTypeOfKind ki2 + + eqs :: [TypeEqn] + eqs = sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2 + in + unifyFunDeps ev Nominal $ \uenv -> + uPairsTcM uenv eqs + + | otherwise -- ordinary, non-injective type family + = return False + +-------------------- +tryFunDeps :: EqCt -> SolverStage () +tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev }) + = Stage $ + case lhs of + TyFamLHS tc args -> do { inerts <- getInertCans + ; imp1 <- improveLocalFunEqs inerts tc args work_item + ; imp2 <- improveTopFunEqs tc args work_item + ; if (imp1 || imp2) + then startAgainWith (mkNonCanonical ev) + else continueWith () } + TyVarLHS {} -> continueWith () + +-------------------- +improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool +-- See Note [FunDep and implicit parameter reactions] +improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs }) + | isGiven ev + = return False -- See Note [No Given/Given fundeps] + + | otherwise + = do { fam_envs <- getFamInstEnvs + ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs + ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs + , ppr eqns ]) + ; unifyFunDeps ev Nominal $ \uenv -> + uPairsTcM (bump_depth uenv) (reverse eqns) } + -- Missing that `reverse` causes T13135 and T13135_simple to loop. + -- See Note [Reverse order of fundep equations] + + where + bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) } + -- ToDo: this location is wrong; it should be FunDepOrigin2 + -- See #14778 + +improve_top_fun_eqs :: FamInstEnvs + -> TyCon -> [TcType] -> TcType + -> TcS [TypeEqn] +improve_top_fun_eqs fam_envs fam_tc args rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = return (sfInteractTop ops args rhs_ty) + + -- see Note [Type inference for type families with injectivity] + | isOpenTypeFamilyTyCon fam_tc + , Injective injective_args <- tyConInjectivityInfo fam_tc + , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc + = -- it is possible to have several compatible equations in an open type + -- family but we only want to derive equalities from one such equation. + do { let improvs = buildImprovementData fam_insts + fi_tvs fi_tys fi_rhs (const Nothing) + + ; traceTcS "improve_top_fun_eqs2" (ppr improvs) + ; concatMapM (injImproveEqns injective_args) $ + take 1 improvs } + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc + , Injective injective_args <- tyConInjectivityInfo fam_tc + = concatMapM (injImproveEqns injective_args) $ + buildImprovementData (fromBranches (co_ax_branches ax)) + cab_tvs cab_lhs cab_rhs Just + + | otherwise + = return [] + + where + in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) + + buildImprovementData + :: [a] -- axioms for a TF (FamInst or CoAxBranch) + -> (a -> [TyVar]) -- get bound tyvars of an axiom + -> (a -> [Type]) -- get LHS of an axiom + -> (a -> Type) -- get RHS of an axiom + -> (a -> Maybe CoAxBranch) -- Just => apartness check required + -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )] + -- Result: + -- ( [arguments of a matching axiom] + -- , RHS-unifying substitution + -- , axiom variables without substitution + -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) + buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap = + [ (ax_args, subst, unsubstTvs, wrap axiom) + | axiom <- axioms + , let ax_args = axiomLHS axiom + ax_rhs = axiomRHS axiom + ax_tvs = axiomTVs axiom + in_scope1 = in_scope `extendInScopeSetList` ax_tvs + , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty] + , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) + unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] + -- The order of unsubstTvs is important; it must be + -- in telescope order e.g. (k:*) (a:k) + + injImproveEqns :: [Bool] + -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch) + -> TcS [TypeEqn] + injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) + = do { subst <- instFlexiX subst unsubstTvs + -- If the current substitution bind [k -> *], and + -- one of the un-substituted tyvars is (a::k), we'd better + -- be sure to apply the current substitution to a's kind. + -- Hence instFlexiX. #13135 was an example. + + ; return [ Pair (substTy subst ax_arg) arg + -- NB: the ax_arg part is on the left + -- see Note [Improvement orientation] + | case cabr of + Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' + _ -> True + , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } + + +improveLocalFunEqs :: InertCans -> TyCon -> [TcType] -> EqCt -> TcS Bool +-- Generate improvement equalities, by comparing +-- the current work item with inert CFunEqs +-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' +-- +-- See Note [FunDep and implicit parameter reactions] +improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs }) + | null improvement_eqns + = return False + | otherwise + = do { traceTcS "interactFunEq improvements: " $ + vcat [ text "Eqns:" <+> ppr improvement_eqns + , text "Candidates:" <+> ppr funeqs_for_tc + , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] + ; emitFunDepWanteds work_ev improvement_eqns } + where + funeqs = inert_funeqs inerts + funeqs_for_tc :: [EqCt] + funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc + , funeq_ct <- equal_ct_list + , NomEq == eq_eq_rel funeq_ct ] + -- representational equalities don't interact + -- with type family dependencies + work_loc = ctEvLoc work_ev + work_pred = ctEvPred work_ev + fam_inj_info = tyConInjectivityInfo fam_tc + + -------------------- + improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + concatMap (do_one_built_in ops rhs) funeqs_for_tc + + | Injective injective_args <- fam_inj_info + = -- Try improvement from type families with injectivity annotations + concatMap (do_one_injective injective_args rhs) funeqs_for_tc + + | otherwise + = [] + + -------------------- + do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev }) + | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] + = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) + + | otherwise + = [] + + do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS + + -------------------- + -- See Note [Type inference for type families with injectivity] + do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args + , eq_rhs = irhs, eq_ev = inert_ev }) + | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] + , rhs `tcEqType` irhs + = mk_fd_eqns inert_ev $ [ Pair arg iarg + | (arg, iarg, True) <- zip3 args inert_args inj_args ] + | otherwise + = [] + + do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS + + -------------------- + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] + mk_fd_eqns inert_ev eqns + | null eqns = [] + | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns + , fd_pred1 = work_pred + , fd_pred2 = inert_pred + , fd_loc = (loc, inert_rewriters) } ] + where + initial_loc -- start with the location of the Wanted involved + | isGiven work_ev = inert_loc + | otherwise = work_loc + eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc) + inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) + eqn_loc = setCtLocOrigin initial_loc eqn_orig + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } + +{- Note [Type inference for type families with injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a type family with an injectivity annotation: + type family F a b = r | r -> b + +Then if we have an equality like F s1 t1 ~ F s2 t2, +we can use the injectivity to get a new Wanted constraint on +the injective argument + [W] t1 ~ t2 + +That in turn can help GHC solve constraints that would otherwise require +guessing. For example, consider the ambiguity check for + f :: F Int b -> Int +We get the constraint + [W] F Int b ~ F Int beta +where beta is a unification variable. Injectivity lets us pick beta ~ b. + +Injectivity information is also used at the call sites. For example: + g = f True +gives rise to + [W] F Int b ~ Bool +from which we can derive b. This requires looking at the defining equations of +a type family, ie. finding equation with a matching RHS (Bool in this example) +and inferring values of type variables (b in this example) from the LHS patterns +of the matching equation. For closed type families we have to perform +additional apartness check for the selected equation to check that the selected +is guaranteed to fire for given LHS arguments. + +These new constraints are Wanted constraints, but we will not use the evidence. +We could go further and offer evidence from decomposing injective type-function +applications, but that would require new evidence forms, and an extension to +FC, so we don't do that right now (Dec 14). + +We generate these Wanteds in three places, depending on how we notice the +injectivity. + +1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and +described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality + +2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these +constraints rewrites the other, as they have different LHSs. This is done +in improveLocalFunEqs, called during the interactWithInertsStage. + +3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. +This is done in improve_top_fun_eqs, called from the top-level reactions stage. + +See also Note [Injective type families] in GHC.Core.TyCon + +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtEvidence), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + (i) Will set g2 := g1 `cast` g3 + (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + (iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. +-} diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs deleted file mode 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ /dev/null @@ -1,2836 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Tc.Solver.Interact ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds -- Solves Cts - ) where - -import GHC.Prelude -import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit ) -import GHC.Tc.Solver.Canonical -import GHC.Types.Var.Set - -import GHC.Types.Var -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.TcType -import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Tc.Instance.FunDeps -import GHC.Tc.Instance.Family -import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) - -import GHC.Tc.Types.Evidence -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import GHC.Tc.Types -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo ) -import GHC.Tc.Solver.Types -import GHC.Tc.Solver.InertSet -import GHC.Tc.Solver.Monad - -import GHC.Core -import GHC.Core.Type as Type -import GHC.Core.InstEnv ( DFunInstType ) -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Reduction -import GHC.Core.Predicate -import GHC.Core.Coercion -import GHC.Core.FamInstEnv -import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) -import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches - , sfInteractInert, sfInteractTop ) - -import GHC.Types.SrcLoc -import GHC.Types.Var.Env -import GHC.Types.Unique( hasKey ) - -import GHC.Data.Bag -import GHC.Data.Pair (Pair(..)) - -import GHC.Utils.Monad ( concatMapM, foldlM ) -import GHC.Utils.Misc - -import GHC.Driver.Session - -import qualified GHC.LanguageExtensions as LangExt - -import Data.List( deleteFirstsBy ) -import Data.Maybe ( listToMaybe, mapMaybe ) -import Data.Function ( on ) -import qualified Data.Semigroup as S - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Control.Monad - -{- -********************************************************************** -* * -* Main Interaction Solver * -* * -********************************************************************** - -Note [Basic Simplifier Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Pick an element from the WorkList if there exists one with depth - less than our context-stack depth. - -2. Run it down the 'stage' pipeline. Stages are: - - canonicalization - - inert reactions - - spontaneous reactions - - top-level interactions - Each stage returns a StopOrContinue and may have sideeffected - the inerts or worklist. - - The threading of the stages is as follows: - - If (Stop) is returned by a stage then we start again from Step 1. - - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to - the next stage in the pipeline. -4. If the element has survived (i.e. ContinueWith x) the last stage - then we add it in the inerts and jump back to Step 1. - -If in Step 1 no such element exists, we have exceeded our context-stack -depth and will simply fail. --} - -solveSimpleGivens :: [Ct] -> TcS () -solveSimpleGivens givens - | null givens -- Shortcut for common case - = return () - | otherwise - = do { traceTcS "solveSimpleGivens {" (ppr givens) - ; go givens - ; traceTcS "End solveSimpleGivens }" empty } - where - go givens = do { solveSimples (listToBag givens) - ; new_givens <- runTcPluginsGiven - ; when (notNull new_givens) $ - go new_givens } - -solveSimpleWanteds :: Cts -> TcS WantedConstraints --- The result is not necessarily zonked -solveSimpleWanteds simples - = do { traceTcS "solveSimpleWanteds {" (ppr simples) - ; dflags <- getDynFlags - ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) - ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } - where - go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) - go n limit wc - | n `intGtLimit` limit - = failTcS $ TcRnSimplifierTooManyIterations simples limit wc - | isEmptyBag (wc_simple wc) - = return (n,wc) - - | otherwise - = do { -- Solve - wc1 <- solve_simple_wanteds wc - - -- Run plugins - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - - ; if rerun_plugin - then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin) - ; go (n+1) limit wc2 } -- Loop - else return (n, wc2) } -- Done - - -solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints --- 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, wc_errors = errs }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, unsolved) <- getUnsolvedInerts - ; return (WC { wc_simple = unsolved - , wc_impl = implics1 `unionBags` implics2 - , wc_errors = errs }) } - -{- Note [The solveSimpleWanteds loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a bunch of simple constraints is done in a loop, -(the 'go' loop of 'solveSimpleWanteds'): - 1. Try to solve them - 2. Try the plugin - 3. If the plugin wants to run again, go back to step 1 --} - --- The main solver loop implements Note [Basic Simplifier Plan] ---------------------------------------------------------------- -solveSimples :: Cts -> TcS () --- Returns the final InertSet in TcS --- Has no effect on work-list or residual-implications --- The constraints are initially examined in left-to-right order - -solveSimples cts - = {-# SCC "solveSimples" #-} - do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts) - ; solve_loop } - where - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem - ; case sel of - Nothing -> return () - Just ct -> do { runSolverPipeline thePipeline ct - ; solve_loop } } - --- | Extract the (inert) givens and invoke the plugins on them. --- Remove solved givens from the inert set and emit insolubles, but --- return new work produced so that 'solveSimpleGivens' can feed it back --- into the main solver. -runTcPluginsGiven :: TcS [Ct] -runTcPluginsGiven - = do { solvers <- getTcPluginSolvers - ; if null solvers then return [] else - do { givens <- getInertGivens - ; if null givens then return [] else - do { p <- runTcPluginSolvers solvers (givens,[]) - ; let (solved_givens, _) = pluginSolvedCts p - insols = pluginBadCts p - ; updInertCans (removeInertCts solved_givens) - ; updInertIrreds (\irreds -> extendCtsList irreds insols) - ; return (pluginNewCts p) } } } - --- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on --- them and produce an updated bag of wanteds (possibly with some new --- work) and a bag of insolubles. The boolean indicates whether --- 'solveSimpleWanteds' should feed the updated wanteds back into the --- main solver. -runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1 }) - | isEmptyBag simples1 - = return (False, wc) - | otherwise - = do { solvers <- getTcPluginSolvers - ; if null solvers then return (False, wc) else - - do { given <- getInertGivens - ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs - ; p <- runTcPluginSolvers solvers (given, bagToList wanted) - ; let (_, solved_wanted) = pluginSolvedCts p - (_, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - insols = pluginBadCts p - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens) - - ; mapM_ setEv solved_wanted - ; return ( notNull (pluginNewCts p) - , wc { wc_simple = listToBag new_wanted `andCts` - listToBag unsolved_wanted `andCts` - listToBag insols } ) } } - where - setEv :: (EvTerm,Ct) -> TcS () - setEv (ev,ct) = case ctEvidence ct of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev - _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" - --- | A pair of (given, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct]) - --- | A solved pair of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [(EvTerm,Ct)]) - --- | Represents collections of constraints generated by typechecker --- plugins -data TcPluginProgress = TcPluginProgress - { pluginInputCts :: SplitCts - -- ^ Original inputs to the plugins with solved/bad constraints - -- removed, but otherwise unmodified - , pluginSolvedCts :: SolvedCts - -- ^ Constraints solved by plugins - , pluginBadCts :: [Ct] - -- ^ Constraints reported as insoluble by plugins - , pluginNewCts :: [Ct] - -- ^ New constraints emitted by plugins - } - -getTcPluginSolvers :: TcS [TcPluginSolver] -getTcPluginSolvers - = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } - --- | Starting from a pair of (given, wanted) constraints, --- invoke each of the typechecker constraint-solving plugins in turn and return --- --- * the remaining unmodified constraints, --- * constraints that have been solved, --- * constraints that are insoluble, and --- * new work. --- --- Note that new work generated by one plugin will not be seen by --- other plugins on this pass (but the main constraint solver will be --- re-invoked and they will see it later). There is no check that new --- work differs from the original constraints supplied to the plugin: --- the plugin itself should perform this check if necessary. -runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress -runTcPluginSolvers solvers all_cts - = do { ev_binds_var <- getTcEvBindsVar - ; foldM (do_plugin ev_binds_var) initialProgress solvers } - where - do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin ev_binds_var p solver = do - result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p)) - return $ progress p result - - progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress - progress p - (TcPluginSolveResult - { tcPluginInsolubleCts = bad_cts - , tcPluginSolvedCts = solved_cts - , tcPluginNewCts = new_cts - } - ) = - p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p) - , pluginSolvedCts = add solved_cts (pluginSolvedCts p) - , pluginNewCts = new_cts ++ pluginNewCts p - , pluginBadCts = bad_cts ++ pluginBadCts p - } - - initialProgress = TcPluginProgress all_cts ([], []) [] [] - - discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys) = - (xs `without` cts, ys `without` cts) - - without :: [Ct] -> [Ct] -> [Ct] - without = deleteFirstsBy eqCt - - eqCt :: Ct -> Ct -> Bool - eqCt c c' = ctFlavour c == ctFlavour c' - && ctPred c `tcEqType` ctPred c' - - add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts - add xs scs = foldl' addOne scs xs - - addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts - addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, wanteds) - CtWanted {} -> (givens, (ev,ct):wanteds) - - -type WorkItem = Ct -type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) - -runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline - -> WorkItem -- The work item - -> TcS () --- Run this item down the pipeline, leaving behind new work and inerts -runSolverPipeline pipeline workItem - = do { wl <- getWorkList - ; inerts <- getTcSInerts - ; tclevel <- getTcLevel - ; traceTcS "----------------------------- " empty - ; traceTcS "Start solver pipeline {" $ - vcat [ text "tclevel =" <+> ppr tclevel - , text "work item =" <+> ppr workItem - , text "inerts =" <+> ppr inerts - , text "rest of worklist =" <+> ppr wl ] - - ; bumpStepCountTcS -- One step for each constraint processed - ; final_res <- run_pipeline pipeline (ContinueWith workItem) - - ; case final_res of - Stop ev s -> do { traceFireTcS ev s - ; traceTcS "End solver pipeline (discharged) }" empty - ; return () } - ContinueWith ct -> do { addInertCan ct - ; traceFireTcS (ctEvidence ct) (text "Kept as inert") - ; traceTcS "End solver pipeline (kept as inert) }" $ - (text "final_item =" <+> ppr ct) } - } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct - -> TcS (StopOrContinue Ct) - run_pipeline [] res = return res - run_pipeline _ (Stop ev s) = return (Stop ev s) - run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) - = do { traceTcS ("runStage " ++ stg_name ++ " {") - (text "workitem = " <+> ppr ct) - ; res <- stg ct - ; traceTcS ("end stage " ++ stg_name ++ " }") empty - ; run_pipeline stgs res } - -{- -Example 1: - Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) - Reagent: a ~ [b] (given) - -React with (c~d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] -React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] - -Example 2: - Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} - Reagent: a ~w [b] - -React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) -etc. - -Example 3: - Inert: {a ~ Int, F Int ~ b} (given) - Reagent: F a ~ b (wanted) - -React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] -React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing --} - -thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", GHC.Tc.Solver.Canonical.canonicalize) - , ("interact with inerts", interactWithInertsStage) - , ("top-level reactions", topReactionsStage) ] - -{- -********************************************************************************* -* * - The interact-with-inert Stage -* * -********************************************************************************* - -Note [The Solver Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We always add Givens first. So you might think that the solver has -the invariant - - If the work-item is Given, - then the inert item must Given - -But this isn't quite true. Suppose we have, - c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int -After processing the first two, we get - c1: [G] beta ~ [alpha], c2 : [W] blah -Now, c3 does not interact with the given c1, so when we spontaneously -solve c3, we must re-react it with the inert set. So we can attempt a -reaction between inert c2 [W] and work-item c3 [G]. - -It *is* true that [Solver Invariant] - If the work-item is Given, - AND there is a reaction - then the inert item must Given -or, equivalently, - If the work-item is Given, - and the inert item is Wanted - then there is no reaction --} - --- Interaction result of WorkItem <~> Ct - -interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CEqCan then it will not be able to --- react with anything at this stage (except, maybe, via a type family --- dependency) - -interactWithInertsStage wi - = do { inerts <- getTcSInerts - ; let ics = inert_cans inerts - ; case wi of - CEqCan {} -> interactEq ics wi - CIrredCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CNonCanonical have been canonicalised - -data InteractResult - = KeepInert -- Keep the inert item, and solve the work item from it - -- (if the latter is Wanted; just discard it if not) - | KeepWork -- Keep the work item, and solve the inert item from it - -instance Outputable InteractResult where - ppr KeepInert = text "keep inert" - ppr KeepWork = text "keep work-item" - -solveOneFromTheOther :: Ct -- Inert (Dict or Irred) - -> Ct -- WorkItem (same predicate as inert) - -> InteractResult --- Precondition: --- * inert and work item represent evidence for the /same/ predicate --- * Both are CDictCan or CIrredCan --- --- We can always solve one from the other: even if both are wanted, --- although we don't rewrite wanteds with wanteds, we can combine --- two wanteds into one by solving one from the other - -solveOneFromTheOther ct_i ct_w - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve loc_i loc_w - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - = -- Inert must be Given - KeepWork - - | CtWanted {} <- ev_w - = -- Inert is Given or Wanted - case ev_i of - CtGiven {} -> KeepInert - -- work is Wanted; inert is Given: easy choice. - - CtWanted {} -- Both are Wanted - -- If only one has no pending superclasses, use it - -- Otherwise we can get infinite superclass expansion (#22516) - -- in silly cases like class C T b => C a b where ... - | not is_psc_i, is_psc_w -> KeepInert - | is_psc_i, not is_psc_w -> KeepWork - - -- If only one is a WantedSuperclassOrigin (arising from expanding - -- a Wanted class constraint), keep the other: wanted superclasses - -- may be unexpected by users - | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork - - -- otherwise, just choose the lower span - -- reason: if we have something like (abs 1) (where the - -- Num constraint cannot be satisfied), it's better to - -- get an error about abs than about 1. - -- This test might become more elaborate if we see an - -- opportunity to improve the error messages - | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert - | otherwise -> KeepWork - - -- From here on the work-item is Given - - | CtWanted { ctev_loc = loc_i } <- ev_i - , prohibitedSuperClassSolve loc_w loc_i - = KeepInert -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted {} <- ev_i - = KeepWork - - -- From here on both are Given - -- See Note [Replacement vs keeping] - - | lvl_i == lvl_w - = same_level_strategy - - | otherwise -- Both are Given, levels differ - = different_level_strategy - where - ev_i = ctEvidence ct_i - ev_w = ctEvidence ct_w - - pred = ctEvPred ev_i - - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - orig_i = ctLocOrigin loc_i - orig_w = ctLocOrigin loc_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - - is_psc_w = isPendingScDict ct_w - is_psc_i = isPendingScDict ct_i - - is_wsc_orig_i = isWantedSuperclassOrigin orig_i - is_wsc_orig_w = isWantedSuperclassOrigin orig_w - - different_level_strategy -- Both Given - | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork - -- See Note [Replacement vs keeping] part (1) - -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] - - same_level_strategy -- Both Given - = case (orig_i, orig_w) of - - (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w) - | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from - | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping] - - -- Both blocked or both not blocked - - | depth_w < depth_i -> KeepWork -- Case 2(c) from - | otherwise -> KeepInert -- Note [Replacement vs keeping] - - (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] - - _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] - -{- -Note [Replacement vs keeping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have two Given constraints both of type (C tys), say, which should -we keep? More subtle than you might think! This is all implemented in -solveOneFromTheOther. - - 1) Constraints come from different levels (different_level_strategy) - - - For implicit parameters we want to keep the innermost (deepest) - one, so that it overrides the outer one. - See Note [Shadowing of Implicit Parameters] - - - For everything else, we want to keep the outermost one. Reason: that - makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. See Note [Tracking redundant constraints] - in GHC.Tc.Solver. - - It transpires that using the outermost one is responsible for an - 8% performance improvement in nofib cryptarithm2, compared to - just rolling the dice. I didn't investigate why. - - 2) Constraints coming from the same level (i.e. same implication) - - (a) If both are GivenSCOrigin, choose the one that is unblocked if possible - according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - - (b) Prefer constraints that are not superclass selections. Example: - - f :: (Eq a, Ord a) => a -> Bool - f x = x == x - - Eager superclass expansion gives us two [G] Eq a constraints. We - want to keep the one from the user-written Eq a, not the superclass - selection. This means we report the Ord a as redundant with - -Wredundant-constraints, not the Eq a. - - Getting this wrong was #20602. See also - Note [Tracking redundant constraints] in GHC.Tc.Solver. - - (c) If both are GivenSCOrigin, chooose the one with the shallower - superclass-selection depth, in the hope of identifying more correct - redundant constraints. This is really a generalization of point (b), - because the superclass depth of a non-superclass constraint is 0. - - (If the levels differ, we definitely won't have both with GivenSCOrigin.) - - (d) Finally, when there is still a choice, use KeepInert rather than - KeepWork, for two reasons: - - to avoid unnecessary munging of the inert set. - - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical - -Doing the level-check for implicit parameters, rather than making the work item -always override, is important. Consider - - data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } - - f :: (?x::a) => T a -> Int - f T1 = ?x - f T2 = 3 - -We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add -two new givens in the work-list: [G] (?x::Int) - [G] (a ~ Int) -Now consider these steps - - process a~Int, kicking out (?x::a) - - process (?x::Int), the inner given, adding to inert set - - process (?x::a), the outer given, overriding the inner given -Wrong! The level-check ensures that the inner implicit parameter wins. -(Actually I think that the order in which the work-list is processed means -that this chain of events won't happen, but that's very fragile.) - -********************************************************************************* -* * - interactIrred -* * -********************************************************************************* - -Note [Multiple matching irreds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that it's impossible to have multiple irreds all match the -work item; after all, interactIrred looks for matches and solves one from the -other. However, note that interacting insoluble, non-droppable irreds does not -do this matching. We thus might end up with several insoluble, non-droppable, -matching irreds in the inert set. When another irred comes along that we have -not yet labeled insoluble, we can find multiple matches. These multiple matches -cause no harm, but it would be wrong to ASSERT that they aren't there (as we -once had done). This problem can be tickled by typecheck/should_compile/holes. - --} - --- Two pieces of irreducible evidence: if their types are *exactly identical* --- we can rewrite them. We can never improve using this: --- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not --- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) - -interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) - | isInsolubleReason reason - -- For insolubles, don't allow the constraint to be dropped - -- which can happen with solveOneFromTheOther, so that - -- we get distinct error messages with -fdefer-type-errors - = continueWith ct_w - - | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w - , ((ct_i, swap) : _rest) <- bagToList matching_irreds - -- See Note [Multiple matching irreds] - , let ev_i = ctEvidence ct_i - = do { traceTcS "iteractIrred" $ - vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w)) - , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ] - ; case solveOneFromTheOther ct_i ct_w of - KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } - KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) - ; updInertIrreds (\_ -> others) - ; continueWith ct_w } } - - | otherwise - = continueWith ct_w - - where - swap_me :: SwapFlag -> CtEvidence -> EvTerm - swap_me swap ev - = case swap of - NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) - -interactIrred _ wi = pprPanic "interactIrred" (ppr wi) - -findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct) -findMatchingIrreds irreds ev - | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred - -- See Note [Solving irreducible equalities] - = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds - | otherwise - = partitionBagWith match_non_eq irreds - where - pred = ctEvPred ev - match_non_eq ct - | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped) - | otherwise = Right ct - - match_eq eq_rel1 lty1 rty1 ct - | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct) - , eq_rel1 == eq_rel2 - , Just swap <- match_eq_help lty1 rty1 lty2 rty2 - = Left (ct, swap) - | otherwise - = Right ct - - match_eq_help lty1 rty1 lty2 rty2 - | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2 - = Just NotSwapped - | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2 - = Just IsSwapped - | otherwise - = Nothing - -{- Note [Solving irreducible equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14333) - [G] a b ~R# c d - [W] c d ~R# a b -Clearly we should be able to solve this! Even though the constraints are -not decomposable. We solve this when looking up the work-item in the -irreducible constraints to look for an identical one. When doing this -lookup, findMatchingIrreds spots the equality case, and matches either -way around. It has to return a swap-flag so we can generate evidence -that is the right way round too. --} - -{- -********************************************************************************* -* * - interactDict -* * -********************************************************************************* - -Note [Shortcut solving] -~~~~~~~~~~~~~~~~~~~~~~~ -When we interact a [W] constraint with a [G] constraint that solves it, there is -a possibility that we could produce better code if instead we solved from a -top-level instance declaration (See #12791, #5835). For example: - - class M a b where m :: a -> b - - type C a b = (Num a, M a b) - - f :: C Int b => b -> Int -> Int - f _ x = x + 1 - -The body of `f` requires a [W] `Num Int` instance. We could solve this -constraint from the givens because we have `C Int b` and that provides us a -solution for `Num Int`. This would let us produce core like the following -(with -O2): - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> - + @ Int - (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) - eta1 - A.f1 - -This is bad! We could do /much/ better if we solved [W] `Num Int` directly -from the instance that we have in scope: - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) _ _ (x :: Int) -> - case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } - -** NB: It is important to emphasize that all this is purely an optimization: -** exactly the same programs should typecheck with or without this -** procedure. - -Solving fully -~~~~~~~~~~~~~ -There is a reason why the solver does not simply try to solve such -constraints with top-level instances. If the solver finds a relevant -instance declaration in scope, that instance may require a context -that can't be solved for. A good example of this is: - - f :: Ord [a] => ... - f x = ..Need Eq [a]... - -If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would -be left with the obligation to solve the constraint Eq a, which we cannot. So we -must be conservative in our attempt to use an instance declaration to solve the -[W] constraint we're interested in. - -Our rule is that we try to solve all of the instance's subgoals -recursively all at once. Precisely: We only attempt to solve -constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci -are themselves class constraints of the form `C1', ... Cm' => C' t1' -... tn'` and we only succeed if the entire tree of constraints is -solvable from instances. - -An example that succeeds: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [Int] b => b -> Bool - f x = m x == [] - -We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This -produces the following core: - - f :: forall b. C [Int] b => b -> Bool - f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> - GHC.Classes.$fEq[]_$s$c== - (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) - -An example that fails: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [a] b => b -> Bool - f x = m x == [] - -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: - - f :: forall a b. C [a] b => b -> Bool - f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> - == - @ [a] - (A.$p1C @ [a] @ b $dC) - (m @ [a] @ b $dC eta) - (GHC.Types.[] @ a) - -Note [Shortcut solving: type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (#13943) - class Take (n :: Nat) where ... - instance {-# OVERLAPPING #-} Take 0 where .. - instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. - -And we have [W] Take 3. That only matches one instance so we get -[W] Take (3-1). Really we should now rewrite to reduce the (3-1) to 2, and -so on -- but that is reproducing yet more of the solver. Sigh. For now, -we just give up (remember all this is just an optimisation). - -But we must not just naively try to lookup (Take (3-1)) in the -InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a -unique match on the (Take n) instance. That leads immediately to an -infinite loop. Hence the check that 'preds' have no type families -(isTyFamFree). - -Note [Shortcut solving: incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This optimization relies on coherence of dictionaries to be correct. When we -cannot assume coherence because of IncoherentInstances then this optimization -can change the behavior of the user's code. - -The following four modules produce a program whose output would change depending -on whether we apply this optimization when IncoherentInstances is in effect: - -========= - {-# LANGUAGE MultiParamTypeClasses #-} - module A where - - class A a where - int :: a -> Int - - class A a => C a b where - m :: b -> a -> a - -========= - {-# LANGUAGE FlexibleInstances #-} - {-# LANGUAGE MultiParamTypeClasses #-} - module B where - - import A - - instance A a where - int _ = 1 - - instance C a [b] where - m _ = id - -========= - {-# LANGUAGE FlexibleContexts #-} - {-# LANGUAGE FlexibleInstances #-} - {-# LANGUAGE IncoherentInstances #-} - {-# LANGUAGE MultiParamTypeClasses #-} - module C where - - import A - - instance A Int where - int _ = 2 - - instance C Int [Int] where - m _ = id - - intC :: C Int a => a -> Int -> Int - intC _ x = int x - -========= - module Main where - - import A - import B - import C - - main :: IO () - main = print (intC [] (0::Int)) - -The output of `main` if we avoid the optimization under the effect of -IncoherentInstances is `1`. If we were to do the optimization, the output of -`main` would be `2`. - -Note [Shortcut try_solve_from_instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The workhorse of the short-cut solver is - try_solve_from_instance :: (EvBindMap, DictMap CtEvidence) - -> CtEvidence -- Solve this - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) -Note that: - -* The CtEvidence is the goal to be solved - -* The MaybeT manages early failure if we find a subgoal that - cannot be solved from instances. - -* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional - state that allows try_solve_from_instance to augment the evidence - bindings and inert_solved_dicts as it goes. - - If it succeeds, we commit all these bindings and solved dicts to the - main TcS InertSet. If not, we abandon it all entirely. - -Passing along the solved_dicts important for two reasons: - -* We need to be able to handle recursive super classes. The - solved_dicts state ensures that we remember what we have already - tried to solve to avoid looping. - -* As #15164 showed, it can be important to exploit sharing between - goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; - and to solve G2 we may need H. If we don't spot this sharing we may - solve H twice; and if this pattern repeats we may get exponentially bad - behaviour. - -Note [No Given/Given fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not create constraints from: -* Given/Given interactions via functional dependencies or type family - injectivity annotations. -* Given/instance fundep interactions via functional dependencies or - type family injectivity annotations. - -In this Note, all these interactions are called just "fundeps". - -We ingore such fundeps for several reasons: - -1. These fundeps will never serve a purpose in accepting more - programs: Given constraints do not contain metavariables that could - be unified via exploring fundeps. They *could* be useful in - discovering inaccessible code. However, the constraints will be - Wanteds, and as such will cause errors (not just warnings) if they - go unsolved. Maybe there is a clever way to get the right - inaccessible code warnings, but the path forward is far from - clear. #12466 has further commentary. - -2. Furthermore, here is a case where a Given/instance interaction is actively - harmful (from dependent/should_compile/RaeJobTalk): - - type family a == b :: Bool - type family Not a = r | r -> a where - Not False = True - Not True = False - - [G] Not (a == b) ~ True - - Reacting this Given with the equations for Not produces - - [W] a == b ~ False - - This is indeed a true consequence, and would make sense as a fresh Given. - But we don't have a way to produce evidence for fundeps, as a Wanted it - is /harmful/: we can't prove it, and so we'll report an error and reject - the program. (Previously fundeps gave rise to Deriveds, which - carried no evidence, so it didn't matter that they could not be proved.) - -3. #20922 showed a subtle different problem with Given/instance fundeps. - type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where - ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss - ... - - tclevel = 4 - [G] ZipCons is1 iss ~ (i : is2) : jss - - (The tclevel=4 means that this Given is at level 4.) The fundep tells us that - 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification - variable; we don't know what type it stands for. So we would emit - [W] iss ~ is2 : beta - - Again we can't prove that equality; and worse we'll rewrite iss to - (is2:beta) in deeply nested constraints inside this implication, - where beta is untouchable (under other equality constraints), leading - to other insoluble constraints. - -The bottom line: since we have no evidence for them, we should ignore Given/Given -and Given/instance fundeps entirely. --} - -interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys - , let ev_i = ctEvidence ct_i - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - = -- There is a matching dictionary in the inert set - do { -- First to try to solve it /completely/ from top level instances - -- See Note [Shortcut solving] - dflags <- getDynFlags - ; short_cut_worked <- shortCutSolver dflags ev_w ev_i - ; if short_cut_worked - then stopWith ev_w "interactDict/solved from instance" - - -- Next see if we are in "loopy-superclass" land. If so, - -- we don't want to replace the (Given) inert with the - -- (Wanted) work-item, or vice versa; we want to hang on - -- to both, and try to solve the work-item via an instance. - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - else if prohibitedSuperClassSolve loc_i loc_w - then continueWith ct_w - else - do { -- The short-cut solver didn't fire, and loopy superclasses - -- are dealt with, so we can either solve - -- the inert from the work-item or vice-versa. - ; case solveOneFromTheOther ct_i ct_w of - KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr ct_w) - ; setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> ppr ct_w) } - KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr ct_w) - ; setEvBindIfWanted ev_i (ctEvTerm ev_w) - ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith ct_w } } } - - | cls `hasKey` ipClassKey - , isGiven ev_w - = interactGivenIP inerts ct_w - - | otherwise - = do { addFunDepWork inerts ev_w cls - ; continueWith ct_w } - -interactDict _ wi = pprPanic "interactDict" (ppr wi) - --- See Note [Shortcut solving] -shortCutSolver :: DynFlags - -> CtEvidence -- Work item - -> CtEvidence -- Inert we want to try to replace - -> TcS Bool -- True <=> success -shortCutSolver dflags ev_w ev_i - | isWanted ev_w - && isGiven ev_i - -- We are about to solve a [W] constraint from a [G] constraint. We take - -- a moment to see if we can get a better solution using an instance. - -- Note that we only do this for the sake of performance. Exactly the same - -- programs should typecheck regardless of whether we take this step or - -- not. See Note [Shortcut solving] - - && not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) - - && not (xopt LangExt.IncoherentInstances dflags) - -- If IncoherentInstances is on then we cannot rely on coherence of proofs - -- in order to justify this optimization: The proof provided by the - -- [G] constraint's superclass may be different from the top-level proof. - -- See Note [Shortcut solving: incoherence] - - && gopt Opt_SolveConstantDicts dflags - -- Enabled by the -fsolve-constant-dicts flag - - = do { ev_binds_var <- getTcEvBindsVar - ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $ - getTcEvBindsMap ev_binds_var - ; solved_dicts <- getSolvedDicts - - ; mb_stuff <- runMaybeT $ try_solve_from_instance - (ev_binds, solved_dicts) ev_w - - ; case mb_stuff of - Nothing -> return False - Just (ev_binds', solved_dicts') - -> do { setTcEvBindsMap ev_binds_var ev_binds' - ; setSolvedDicts solved_dicts' - ; return True } } - - | otherwise - = return False - where - -- This `CtLoc` is used only to check the well-staged condition of any - -- candidate DFun. Our subgoals all have the same stage as our root - -- [W] constraint so it is safe to use this while solving them. - loc_w = ctEvLoc ev_w - - try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] - :: (EvBindMap, DictMap CtEvidence) -> CtEvidence - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) - try_solve_from_instance (ev_binds, solved_dicts) ev - | let pred = ctEvPred ev - loc = ctEvLoc ev - , ClassPred cls tys <- classifyPredType pred - = do { inst_res <- lift $ matchGlobalInst dflags True cls tys - ; case inst_res of - OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = what } - | safeOverlap what - , all isTyFamFree preds -- Note [Shortcut solving: type families] - -> do { let solved_dicts' = addDict solved_dicts cls tys ev - -- solved_dicts': it is important that we add our goal - -- to the cache before we solve! Otherwise we may end - -- up in a loop while solving recursive dictionaries. - - ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) - ; loc' <- lift $ checkInstanceOK loc what pred - ; lift $ checkReductionDepth loc' pred - - - ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds - -- Emit work for subgoals but use our local cache - -- so we can solve recursive dictionaries. - - ; let ev_tm = mk_ev (map getEvExpr evc_vs) - ev_binds' = extendEvBinds ev_binds $ - mkWantedEvBind (ctEvEvId ev) ev_tm - - ; foldlM try_solve_from_instance - (ev_binds', solved_dicts') - (freshGoals evc_vs) } - - _ -> mzero } - | otherwise = mzero - - - -- Use a local cache of solved dicts while emitting EvVars for new work - -- We bail out of the entire computation if we need to emit an EvVar for - -- a subgoal that isn't a ClassPred. - new_wanted_cached :: CtEvidence -> CtLoc - -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached ev_w loc cache pty - | ClassPred cls tys <- classifyPredType pty - = lift $ case findDict cache loc_w cls tys of - Just ctev -> return $ Cached (ctEvExpr ctev) - Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty - | otherwise = mzero - -addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add wanted constraints from type-class functional dependencies. -addFunDepWork inerts work_ev cls - = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) - -- No need to check flavour; fundeps work between - -- any pair of constraints, regardless of flavour - -- Importantly we don't throw workitem back in the - -- worklist because this can cause loops (see #5236) - where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds inert_ct - = do { traceTcS "addFunDepWork" (vcat - [ ppr work_ev - , pprCtLoc work_loc, ppr (isGivenLoc work_loc) - , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) - , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) - - ; unless (isGiven work_ev && isGiven inert_ev) $ - emitFunDepWanteds (ctEvRewriters work_ev) $ - improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred - -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] - } - where - inert_ev = ctEvidence inert_ct - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - inert_rewriters = ctRewriters inert_ct - derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` - ctl_depth inert_loc - , ctl_origin = FunDepOrigin1 work_pred - (ctLocOrigin work_loc) - (ctLocSpan work_loc) - inert_pred - (ctLocOrigin inert_loc) - (ctLocSpan inert_loc) } - -{- -********************************************************************** -* * - Implicit parameters -* * -********************************************************************** --} - -interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Work item is Given (?x:ty) --- See Note [Shadowing of Implicit Parameters] -interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = tys@(ip_str:_) }) - = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } - ; stopWith ev "Given IP" } - where - dicts = inert_dicts inerts - ip_dicts = findDictsByClass dicts cls - other_ip_dicts = filterBag (not . is_this_ip) ip_dicts - filtered_dicts = addDictsByClass dicts cls other_ip_dicts - - -- Pick out any Given constraints for the same implicit parameter - is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) - = isGiven ev && ip_str `tcEqType` ip_str' - is_this_ip _ = False - -interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) - -{- Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x - -The "let ?x = ..." generates an implication constraint of the form: - -?x :: Char => ?x :: Char - -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: - -?x :: Char => (?x :: Char => ?x :: Char) - -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we add a new -*given* implicit parameter to the inert set, it replaces any existing -givens for the same implicit parameter. - -Similarly, consider - f :: (?x::a) => Bool -> a - - g v = let ?x::Int = 3 - in (f v, let ?x::Bool = True in f v) - -This should probably be well typed, with - g :: Bool -> (Int, Bool) - -So the inner binding for ?x::Bool *overrides* the outer one. - -See ticket #17104 for a rather tricky example of this overriding -behaviour. - -All this works for the normal cases but it has an odd side effect in -some pathological programs like this: --- This is accepted, the second parameter shadows -f1 :: (?x :: Int, ?x :: Char) => Char -f1 = ?x - --- This is rejected, the second parameter shadows -f2 :: (?x :: Int, ?x :: Char) => Int -f2 = ?x - -Both of these are actually wrong: when we try to use either one, -we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), -which would lead to an error. - -I can think of two ways to fix this: - - 1. Simply disallow multiple constraints for the same implicit - parameter---this is never useful, and it can be detected completely - syntactically. - - 2. Move the shadowing machinery to the location where we nest - implications, and add some code here that will produce an - error if we get multiple givens for the same implicit parameter. - - -********************************************************************** -* * - interactFunEq -* * -********************************************************************** --} - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType - -> TcS () --- Generate improvement equalities, by comparing --- the current work item with inert CFunEqs --- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' --- --- See Note [FunDep and implicit parameter reactions] -improveLocalFunEqs work_ev inerts fam_tc args rhs - = unless (null improvement_eqns) $ - do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr improvement_eqns - , text "Candidates:" <+> ppr funeqs_for_tc - , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] - ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns } - where - funeqs = inert_funeqs inerts - funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc - , funeq_ct <- equal_ct_list - , NomEq == ctEqRel funeq_ct ] - -- representational equalities don't interact - -- with type family dependencies - work_loc = ctEvLoc work_ev - work_pred = ctEvPred work_ev - fam_inj_info = tyConInjectivityInfo fam_tc - - -------------------- - improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - concatMap (do_one_built_in ops rhs) funeqs_for_tc - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - concatMap (do_one_injective injective_args rhs) funeqs_for_tc - - | otherwise - = [] - - -------------------- - do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev }) - | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] - = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) - - | otherwise - = [] - - do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) - - -------------------- - -- See Note [Type inference for type families with injectivity] - do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args - , cc_rhs = irhs, cc_ev = inert_ev }) - | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] - , rhs `tcEqType` irhs - = mk_fd_eqns inert_ev $ [ Pair arg iarg - | (arg, iarg, True) <- zip3 args inert_args inj_args ] - | otherwise - = [] - - do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] - mk_fd_eqns inert_ev eqns - | null eqns = [] - | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns - , fd_pred1 = work_pred - , fd_pred2 = inert_pred - , fd_loc = (loc, inert_rewriters) } ] - where - initial_loc -- start with the location of the Wanted involved - | isGiven work_ev = inert_loc - | otherwise = work_loc - eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc) - inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) - eqn_loc = setCtLocOrigin initial_loc eqn_orig - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - inert_rewriters = ctEvRewriters inert_ev - loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -{- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a type family with an injectivity annotation: - type family F a b = r | r -> b - -Then if we have an equality like F s1 t1 ~ F s2 t2, -we can use the injectivity to get a new Wanted constraint on -the injective argument - [W] t1 ~ t2 - -That in turn can help GHC solve constraints that would otherwise require -guessing. For example, consider the ambiguity check for - f :: F Int b -> Int -We get the constraint - [W] F Int b ~ F Int beta -where beta is a unification variable. Injectivity lets us pick beta ~ b. - -Injectivity information is also used at the call sites. For example: - g = f True -gives rise to - [W] F Int b ~ Bool -from which we can derive b. This requires looking at the defining equations of -a type family, ie. finding equation with a matching RHS (Bool in this example) -and inferring values of type variables (b in this example) from the LHS patterns -of the matching equation. For closed type families we have to perform -additional apartness check for the selected equation to check that the selected -is guaranteed to fire for given LHS arguments. - -These new constraints are Wanted constraints, but we will not use the evidence. -We could go further and offer evidence from decomposing injective type-function -applications, but that would require new evidence forms, and an extension to -FC, so we don't do that right now (Dec 14). - -We generate these Wanteds in three places, depending on how we notice the -injectivity. - -1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and -described in Note [Decomposing type family applications] in GHC.Tc.Solver.Canonical. - -2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these -constraints rewrites the other, as they have different LHSs. This is done -in improveLocalFunEqs, called during the interactWithInertsStage. - -3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. -This is done in improve_top_fun_eqs, called from the top-level reactions stage. - -See also Note [Injective type families] in GHC.Core.TyCon - -Note [Cache-caused loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very dangerous to cache a rewritten wanted family equation as 'solved' in our -solved cache (which is the default behaviour or xCtEvidence), because the interaction -may not be contributing towards a solution. Here is an example: - -Initial inert set: - [W] g1 : F a ~ beta1 -Work item: - [W] g2 : F a ~ beta2 -The work item will react with the inert yielding the _same_ inert set plus: - (i) Will set g2 := g1 `cast` g3 - (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 - (iii) Will emit [W] g3 : beta1 ~ beta2 -Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 -and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it -will set - g1 := g ; sym g3 -and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but -remember that we have this in our solved cache, and it is ... g2! In short we -created the evidence loop: - - g2 := g1 ; g3 - g3 := refl - g1 := g2 ; sym g3 - -To avoid this situation we do not cache as solved any workitems (or inert) -which did not really made a 'step' towards proving some goal. Solved's are -just an optimization so we don't lose anything in terms of completeness of -solving. - -********************************************************************** -* * - interactEq -* * -********************************************************************** --} - -{- Note [Combining equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - Inert: g1 :: a ~ t - Work item: g2 :: a ~ t - -Then we can simply solve g2 from g1, thus g2 := g1. Easy! -But it's not so simple: - -* If t is a type variable, the equalties might be oriented differently: - e.g. (g1 :: a~b) and (g2 :: b~a) - So we look both ways round. Hence the SwapFlag result to - inertsCanDischarge. - -* We can only do g2 := g1 if g1 can discharge g2; that depends on - (a) the role and (b) the flavour. E.g. a representational equality - cannot discharge a nominal one; a Wanted cannot discharge a Given. - The predicate is eqCanRewriteFR. - -* Visibility. Suppose S :: forall k. k -> Type, and consider unifying - S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type) - From the first argument we get (Type ~ Type->Type); from the second - argument we get (a ~ b) which in turn gives (Type ~ Type->Type). - See typecheck/should_fail/T16204c. - - That first argument is invisible in the source program (aside from - visible type application), so we'd much prefer to get the error from - the second. We track visibility in the uo_visible field of a TypeEqOrigin. - We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters, - the partition on isVisibleOrigin). - - So when combining two otherwise-identical equalites, we want to - keep the visible one, and discharge the invisible one. Hence the - call to strictly_more_visible. --} - -inertsCanDischarge :: InertCans -> Ct - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag ) -- Whether we need mkSymCo -inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w - , cc_ev = ev_w, cc_eq_rel = eq_rel }) - | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findEq inerts lhs_w - , rhs_i `tcEqType` rhs_w - , inert_beats_wanted ev_i eq_rel ] - = -- Inert: a ~ ty - -- Work item: a ~ ty - Just (ev_i, NotSwapped) - - | Just rhs_lhs <- canEqLHS_maybe rhs_w - , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findEq inerts rhs_lhs - , rhs_i `tcEqType` canEqLHSType lhs_w - , inert_beats_wanted ev_i eq_rel ] - = -- Inert: a ~ b - -- Work item: b ~ a - Just (ev_i, IsSwapped) - - where - loc_w = ctEvLoc ev_w - flav_w = ctEvFlavour ev_w - fr_w = (flav_w, eq_rel) - - inert_beats_wanted ev_i eq_rel - = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] - -- strictly_more_visible: see last bullet of Note [Combining equalities] - fr_i `eqCanRewriteFR` fr_w - && not ((loc_w `strictly_more_visible` ctEvLoc ev_i) - && (fr_w `eqCanRewriteFR` fr_i)) - where - fr_i = (ctEvFlavour ev_i, eq_rel) - - -- See Note [Combining equalities], final bullet - strictly_more_visible loc1 loc2 - = not (isVisibleOrigin (ctLocOrigin loc2)) && - isVisibleOrigin (ctLocOrigin loc1) - -inertsCanDischarge _ _ = Nothing - - -interactEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactEq inerts workItem@(CEqCan { cc_lhs = lhs - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem - = do { setEvBindIfWanted ev $ - evCoercion (maybeSymCo swapped $ - downgradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - - ; stopWith ev "Solved from inert" } - - | ReprEq <- eq_rel -- See Note [Do not unify representational equalities] - = do { traceTcS "Not unifying representational equality" (ppr workItem) - ; continueWith workItem } - - | otherwise - = case lhs of - TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs - - TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs - ; continueWith workItem } - -interactEq _ wi = pprPanic "interactEq" (ppr wi) - ----------------------- --- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes" --- So try to solve by unifying. --- Three reasons why not: --- Skolem escape --- Given equalities (GADTs) --- Unifying a TyVarTv with a non-tyvar type -tryToSolveByUnification :: Ct -> CtEvidence - -> TcTyVar -- LHS tyvar - -> TcType -- RHS - -> TcS (StopOrContinue Ct) -tryToSolveByUnification work_item ev tv rhs - = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs - ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs - , ppr is_touchable ]) - - ; case is_touchable of - Untouchable -> continueWith work_item - -- For the latter two cases see Note [Solve by unification] - TouchableSameLevel -> solveByUnification ev tv rhs - TouchableOuterLevel free_metas tv_lvl - -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas - ; setUnificationFlag tv_lvl - ; solveByUnification ev tv rhs } } - -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) --- Solve with the identity coercion --- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted --- Precondition: CtEvidence is nominal --- Returns: workItem where --- workItem = the new Given constraint --- --- NB: No need for an occurs check here, because solveByUnification always --- arises from a CEqCan, a *canonical* constraint. Its invariant (TyEq:OC) --- says that in (a ~ xi), the type variable a does not appear in xi. --- See GHC.Tc.Types.Constraint.Ct invariants. --- --- Post: tv is unified (by side effect) with xi; --- we often write tv := xi -solveByUnification wd tv xi - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, - text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (typeKind tv_ty), - text "Right Kind is:" <+> ppr (typeKind xi) ] - ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkNomReflCo xi)) - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) } - -{- Note [Avoid double unifications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The spontaneous solver has to return a given which mentions the unified unification -variable *on the left* of the equality. Here is what happens if not: - Original wanted: (a ~ alpha), (alpha ~ Int) -We spontaneously solve the first wanted, without changing the order! - given : a ~ alpha [having unified alpha := a] -Now the second wanted comes along, but it cannot rewrite the given, so we simply continue. -At the end we spontaneously solve that guy, *reunifying* [alpha := Int] - -We avoid this problem by orienting the resulting given so that the unification -variable is on the left (note that alternatively we could attempt to -enforce this at canonicalization). - -See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding -double unifications is the main reason we disallow touchable -unification variables as RHS of type family equations: F xis ~ alpha. - -Note [Do not unify representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [W] alpha ~R# b -where alpha is touchable. Should we unify alpha := b? - -Certainly not! Unifying forces alpha and be to be the same; but they -only need to be representationally equal types. - -For example, we might have another constraint [W] alpha ~# N b -where - newtype N b = MkN b -and we want to get alpha := N b. - -See also #15144, which was caused by unifying a representational -equality. - -Note [Solve by unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we solve - alpha[n] ~ ty -by unification, there are two cases to consider - -* TouchableSameLevel: if the ambient level is 'n', then - we can simply update alpha := ty, and do nothing else - -* TouchableOuterLevel free_metas n: if the ambient level is greater than - 'n' (the level of alpha), in addition to setting alpha := ty we must - do two other things: - - 1. Promote all the free meta-vars of 'ty' to level n. After all, - alpha[n] is at level n, and so if we set, say, - alpha[n] := Maybe beta[m], - we must ensure that when unifying beta we do skolem-escape checks - etc relevant to level n. Simple way to do that: promote beta to - level n. - - 2. Set the Unification Level Flag to record that a level-n unification has - taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad - -NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion -would be a no-op, and setting the unification flag unnecessarily would just -make the solver iterate more often. (We don't need to iterate when unifying -at the ambient level because of the kick-out mechanism.) - - -************************************************************************ -* * -* Functional dependencies, instantiation of equations -* * -************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer -now!). - -Note [FunDep and implicit parameter reactions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, our story of interacting two dictionaries (or a dictionary -and top-level instances) for functional dependencies, and implicit -parameters, is that we simply produce new Wanted equalities. So for example - - class D a b | a -> b where ... - Inert: - d1 :g D Int Bool - WorkItem: - d2 :w D Int alpha - - We generate the extra work item - cv :w alpha ~ Bool - where 'cv' is currently unused. However, this new item can perhaps be - spontaneously solved to become given and react with d2, - discharging it in favour of a new constraint d2' thus: - d2' :w D Int Bool - d2 := d2' |> D Int cv - Now d2' can be discharged from d1 - -We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities. - -If that were the case with the same inert set and work item we might discard -d2 directly: - - cv :w alpha ~ Bool - d2 := d1 |> D Int cv - -But in general it's a bit painful to figure out the necessary coercion, -so we just take the first approach. Here is a better example. Consider: - class C a b c | a -> b -And: - [Given] d1 : C T Int Char - [Wanted] d2 : C T beta Int -In this case, it's *not even possible* to solve the wanted immediately. -So we should simply output the functional dependency and add this guy -[but NOT its superclasses] back in the worklist. Even worse: - [Given] d1 : C T Int beta - [Wanted] d2: C T beta Int -Then it is solvable, but its very hard to detect this on the spot. - -It's exactly the same with implicit parameters, except that the -"aggressive" approach would be much easier to implement. - -Note [Fundeps with instances, and equality orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note describes a delicate interaction that constrains the orientation of -equalities. This one is about fundeps, but the /exact/ same thing arises for -type-family injectivity constraints: see Note [Improvement orientation]. - -doTopFundepImprovement compares the constraint with all the instance -declarations, to see if we can produce any equalities. E.g - class C2 a b | a -> b - instance C Int Bool -Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. - -There is a nasty corner in #19415 which led to the typechecker looping: - class C s t b | s -> t - instance ... => C (T kx x) (T ky y) Int - T :: forall k. k -> Type - - work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char - where kb0, b0 are unification vars - - ==> {doTopFundepImprovement: compare work_item with instance, - generate /fresh/ unification variables kfresh0, yfresh0, - emit a new Wanted, and add dwrk to inert set} - - Suppose we emit this new Wanted from the fundep: - [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) - - ==> {solve that equality kb0 := kfresh0, b0 := yfresh0} - Now kick out dwrk, since it mentions kb0 - But now we are back to the start! Loop! - -NB1: This example relies on an instance that does not satisfy the - coverage condition (although it may satisfy the weak coverage - condition), and hence whose fundeps generate fresh unification - variables. Not satisfying the coverage condition is known to - lead to termination trouble, but in this case it's plain silly. - -NB2: In this example, the third parameter to C ensures that the - instance doesn't actually match the Wanted, so we can't use it to - solve the Wanted - -We solve the problem by (#21703): - - carefully orienting the new Wanted so that all the - freshly-generated unification variables are on the LHS. - - Thus we emit - [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) - and /NOT/ - [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) - -Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well. The general idea -is that we want to preferentially eliminate those freshly-generated -unification variables, rather than unifying older variables, which causes -kick-out etc. - -Keeping younger variables on the left also gives very minor improvement in -the compiler performance by having less kick-outs and allocations (-0.1% on -average). Indeed Historical Note [Eliminate younger unification variables] -in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically, -apparently now in abeyance. - -But this is is a delicate solution. We must take care to /preserve/ -orientation during solving. Wrinkles: - -(W1) We start with - [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) - Decompose to - [W] kfresh0 ~ kb0 - [W] (yfresh0::kfresh0) ~ (b0::kb0) - Preserve orientiation when decomposing!! - -(W2) Suppose we happen to tackle the second Wanted from (W1) - first. Then in canEqCanLHSHetero we emit a /kind/ equality, as - well as a now-homogeneous type equality - [W] kco : kfresh0 ~ kb0 - [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco) - Preserve orientation in canEqCanLHSHetero!! (Failing to - preserve orientation here was the immediate cause of #21703.) - -(W3) There is a potential interaction with the swapping done by - GHC.Tc.Utils.Unify.swapOverTyVars. We think it's fine, but it's - a slight worry. See especially Note [TyVar/TyVar orientation] in - that module. - -The trouble is that "preserving orientation" is a rather global invariant, -and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't -even have a precise statement of what the invariant is. The advantage -of the preserve-orientation plan is that it is extremely cheap to implement, -and apparently works beautifully. - ---- Alternative plan (1) --- -Rather than have an ill-defined invariant, another possiblity is to -elminate those fresh unification variables at birth, when generating -the new fundep-inspired equalities. - -The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those -type variables that are guaranteed to give us some progress. This means we -have to locally (without calling emitWanteds) identify the type variables -that do not give us any progress. In the above example, we _know_ that -emitting the two wanteds `kco` and `co` is fruitless. - - Q: How do we identify such no-ops? - - 1. Generate a matching substitution from LHS to RHS - ɸ = [kb0 :-> k0, b0 :-> y0] - 2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ - ɸ' = instFlexiX ɸ (tvs - domain ɸ) - 3. Apply ɸ' on LHS and then call emitWanteds - unifyWanteds ... (subst ɸ' LHS) RHS - -Why will this work? The matching substitution ɸ will be a best effort -substitution that gives us all the easy solutions. It can be generated with -modified version of `Core/Unify.unify_tys` where we run it in a matching mode -and never generate `SurelyApart` and always return a `MaybeApart Subst` -instead. - -The same alternative plan would work for type-family injectivity constraints: -see Note [Improvement orientation]. ---- End of Alternative plan (1) --- - ---- Alternative plan (2) --- -We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo) -for the fresh unification variables introduced by functional dependencies. Say `FunDepTv`. Then in -GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible. -Looks possible, but it's one more complication. ---- End of Alternative plan (2) --- - - ---- Historical note: Failed Alternative Plan (3) --- -Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False -once we used a fun dep to hint the solver to break and to stop emitting more -wanteds. This solution was not complete, and caused a failures while trying -to solve for transitive functional dependencies (test case: T21703) --- End of Historical note: Failed Alternative Plan (3) -- - -Note [Weird fundeps] -~~~~~~~~~~~~~~~~~~~~ -Consider class Het a b | a -> b where - het :: m (f c) -> a -> m b - - class GHet (a :: * -> *) (b :: * -> *) | a -> b - instance GHet (K a) (K [a]) - instance Het a b => GHet (K a) (K b) - -The two instances don't actually conflict on their fundeps, -although it's pretty strange. So they are both accepted. Now -try [W] GHet (K Int) (K Bool) -This triggers fundeps from both instance decls; - [W] K Bool ~ K [a] - [W] K Bool ~ K beta -And there's a risk of complaining about Bool ~ [a]. But in fact -the Wanted matches the second instance, so we never get as far -as the fundeps. - -#7875 is a case in point. --} - -doTopFundepImprovement :: Ct -> TcS () --- Try to functional-dependency improvement between the constraint --- and the top-level instance declarations --- See Note [Fundeps with instances, and equality orientation] --- See also Note [Weird fundeps] -doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis }) - = do { traceTcS "try_fundeps" (ppr work_item) - ; instEnvs <- getInstEnvs - ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis - ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns } - where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc ev - dict_origin = ctLocOrigin dict_loc - - mk_ct_loc :: PredType -- From instance decl - -> SrcSpan -- also from instance deol - -> (CtLoc, RewriterSet) - mk_ct_loc inst_pred inst_loc - = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } - , emptyRewriterSet ) - -doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item) - -emitFunDepWanteds :: RewriterSet -- from the work item - -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () - -emitFunDepWanteds _ [] = return () -- common case noop --- See Note [FunDep and implicit parameter reactions] - -emitFunDepWanteds work_rewriters fd_eqns - = mapM_ do_one_FDEqn fd_eqns - where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) - | null tvs -- Common shortcut - = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) - ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2) - (reverse eqs) } - -- See Note [Reverse order of fundep equations] - - | otherwise - = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexiX emptySubst tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) } - -- See Note [Reverse order of fundep equations] - where - all_rewriters = work_rewriters S.<> rewriters - - do_one_eq loc rewriters subst (Pair ty1 ty2) - = unifyWanted rewriters loc Nominal (substTyUnchecked subst' ty1) ty2 - -- ty2 does not mention fd_qtvs, so no need to subst it. - -- See GHC.Tc.Instance.Fundeps Note [Improving against instances] - -- Wrinkle (1) - where - subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) - -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result - -- of matching with the [W] constraint. So we add its free - -- vars to InScopeSet, to satisfy substTy's invariants, even - -- though ty1 will never (currently) be a poytype, so this - -- InScopeSet will never be looked at. - -{- -********************************************************************** -* * - The top-reaction Stage -* * -********************************************************************** --} - -topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) --- The work item does not react with the inert set, --- so try interaction with top-level instances. -topReactionsStage work_item - = do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - - CDictCan {} -> - do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - - CEqCan {} -> - doTopReactEq work_item - - CIrredCan {} -> - doTopReactOther work_item - - -- Any other work item does not react with any top-level equations - _ -> continueWith work_item } - --------------------- -doTopReactOther :: Ct -> TcS (StopOrContinue Ct) --- Try local quantified constraints for --- CEqCan e.g. (lhs ~# ty) --- and CIrredCan e.g. (c a) --- --- Why equalities? See GHC.Tc.Solver.Canonical --- Note [Equality superclasses in quantified constraints] -doTopReactOther work_item - | isGiven ev - = continueWith work_item - - | EqPred eq_rel t1 t2 <- classifyPredType pred - = doTopReactEqPred work_item eq_rel t1 t2 - - | otherwise - = do { res <- matchLocalInst pred loc - ; case res of - OneInst {} -> chooseInstance ev res - _ -> continueWith work_item } - - where - ev = ctEvidence work_item - loc = ctEvLoc ev - pred = ctEvPred ev - -{-******************************************************************** -* * - Top-level reaction for equality constraints (CEqCan) -* * -********************************************************************-} - -doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) -doTopReactEqPred work_item eq_rel lhs rhs - -- See Note [Looking up primitive equalities in quantified constraints] - = do { ev_binds_var <- getTcEvBindsVar - ; ics <- getInertCans - ; if isWanted ev -- Never look up Givens in quantified constraints - && not (null (inert_insts ics)) -- Shortcut common case - && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications] - then try_for_qci - else continueWith work_item } - where - ev = ctEvidence work_item - loc = ctEvLoc ev - - role = eqRelRole eq_rel - try_for_qci -- First try looking for (lhs ~ rhs) - | Just (cls, tys) <- boxEqPred eq_rel lhs rhs - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; traceTcS "final_qci_check:1" (ppr (mkClassPred cls tys)) - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) - _ -> try_swapping } - | otherwise - = continueWith work_item - - try_swapping -- Now try looking for (rhs ~ lhs) (see #23333) - | Just (cls, tys) <- boxEqPred eq_rel rhs lhs - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; traceTcS "final_qci_check:2" (ppr (mkClassPred cls tys)) - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped - (mkReflRedn role rhs) (mkReflRedn role lhs) - ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } - _ -> do { traceTcS "final_qci_check:3" (ppr work_item) - ; continueWith work_item }} - | otherwise - = continueWith work_item - - mk_eq_ev cls tys mk_ev evs - = case (mk_ev evs) of - EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) - ev -> pprPanic "mk_eq_ev" (ppr ev) - where - [sc_id] = classSCSelIds cls - -{- Note [Looking up primitive equalities in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For equalities (a ~# b) look up (a ~ b), and then do a superclass -selection. This avoids having to support quantified constraints whose -kind is not Constraint, such as (forall a. F a ~# b) - -See - * Note [Evidence for quantified constraints] in GHC.Core.Predicate - * Note [Equality superclasses in quantified constraints] - in GHC.Tc.Solver.Canonical - -Note [Reverse order of fundep equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this scenario (from dependent/should_fail/T13135_simple): - - type Sig :: Type -> Type - data Sig a = SigFun a (Sig a) - - type SmartFun :: forall (t :: Type). Sig t -> Type - type family SmartFun sig = r | r -> sig where - SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig - - [W] SmartFun @kappa sigma ~ (Int -> Bool) - -The injectivity of SmartFun allows us to produce two new equalities: - - [W] w1 :: Type ~ kappa - [W] w2 :: SigFun @Type Int beta ~ sigma - -for some fresh (beta :: SigType). The second Wanted here is actually -heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. -Of course, if we solve the first wanted first, the second becomes homogeneous. - -When looking for injectivity-inspired equalities, we work left-to-right, -producing the two equalities in the order written above. However, these -equalities are then passed into unifyWanted, which will fail, adding these -to the work list. However, crucially, the work list operates like a *stack*. -So, because we add w1 and then w2, we process w2 first. This is silly: solving -w1 would unlock w2. So we make sure to add equalities to the work -list in left-to-right order, which requires a few key calls to 'reverse'. - -This treatment is also used for class-based functional dependencies, although -we do not have a program yet known to exhibit a loop there. It just seems -like the right thing to do. - -When this was originally conceived, it was necessary to avoid a loop in T13135. -That loop is now avoided by continuing with the kind equality (not the type -equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds] -in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still -seems worthwhile, and so the calls to 'reverse' remain. - --} - --------------------- -doTopReactEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args - , cc_rhs = rhs }) - = do { improveTopFunEqs old_ev fam_tc args rhs - ; doTopReactOther work_item } -doTopReactEq work_item = doTopReactOther work_item - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args rhs - | isGiven ev -- See Note [No Given/Given fundeps] - = return () - - | otherwise - = do { fam_envs <- getFamInstEnvs - ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs - , ppr eqns ]) - ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2) - (reverse eqns) } - -- Missing that `reverse` causes T13135 and T13135_simple to loop. - -- See Note [Reverse order of fundep equations] - where - loc = bumpCtLocDepth (ctEvLoc ev) - -- ToDo: this location is wrong; it should be FunDepOrigin2 - -- See #14778 - rewriters = ctEvRewriters ev - -improve_top_fun_eqs :: FamInstEnvs - -> TyCon -> [TcType] -> TcType - -> TcS [TypeEqn] -improve_top_fun_eqs fam_envs fam_tc args rhs_ty - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = return (sfInteractTop ops args rhs_ty) - - -- see Note [Type inference for type families with injectivity] - | isOpenTypeFamilyTyCon fam_tc - , Injective injective_args <- tyConInjectivityInfo fam_tc - , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc - = -- it is possible to have several compatible equations in an open type - -- family but we only want to derive equalities from one such equation. - do { let improvs = buildImprovementData fam_insts - fi_tvs fi_tys fi_rhs (const Nothing) - - ; traceTcS "improve_top_fun_eqs2" (ppr improvs) - ; concatMapM (injImproveEqns injective_args) $ - take 1 improvs } - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc - , Injective injective_args <- tyConInjectivityInfo fam_tc - = concatMapM (injImproveEqns injective_args) $ - buildImprovementData (fromBranches (co_ax_branches ax)) - cab_tvs cab_lhs cab_rhs Just - - | otherwise - = return [] - - where - in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) - - buildImprovementData - :: [a] -- axioms for a TF (FamInst or CoAxBranch) - -> (a -> [TyVar]) -- get bound tyvars of an axiom - -> (a -> [Type]) -- get LHS of an axiom - -> (a -> Type) -- get RHS of an axiom - -> (a -> Maybe CoAxBranch) -- Just => apartness check required - -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )] - -- Result: - -- ( [arguments of a matching axiom] - -- , RHS-unifying substitution - -- , axiom variables without substitution - -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) - buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap = - [ (ax_args, subst, unsubstTvs, wrap axiom) - | axiom <- axioms - , let ax_args = axiomLHS axiom - ax_rhs = axiomRHS axiom - ax_tvs = axiomTVs axiom - in_scope1 = in_scope `extendInScopeSetList` ax_tvs - , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty] - , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) - unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] - -- The order of unsubstTvs is important; it must be - -- in telescope order e.g. (k:*) (a:k) - - injImproveEqns :: [Bool] - -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch) - -> TcS [TypeEqn] - injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) - = do { subst <- instFlexiX subst unsubstTvs - -- If the current substitution bind [k -> *], and - -- one of the un-substituted tyvars is (a::k), we'd better - -- be sure to apply the current substitution to a's kind. - -- Hence instFlexiX. #13135 was an example. - - ; return [ Pair (substTy subst ax_arg) arg - -- NB: the ax_arg part is on the left - -- see Note [Improvement orientation] - | case cabr of - Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' - _ -> True - , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } - -{- -Note [MATCHING-SYNONYMS] -~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to match a dictionary (D tau) to a top-level instance, or a -type family equation (F taus_1 ~ tau_2) to a top-level family instance, -we do *not* need to expand type synonyms because the matcher will do that for us. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Fundeps with instances, and equality orientation], which describes -the Exact Same Prolem, with the same solution, but for functional dependencies. - -A very delicate point is the orientation of equalities -arising from injectivity improvement (#12522). Suppose we have - type family F x = t | t -> x - type instance F (a, Int) = (Int, G a) -where G is injective; and wanted constraints - - [W] TF (alpha, beta) ~ fuv - [W] fuv ~ (Int, ) - -The injectivity will give rise to constraints - - [W] gamma1 ~ alpha - [W] Int ~ beta - -The fresh unification variable gamma1 comes from the fact that we -can only do "partial improvement" here; see Section 5.2 of -"Injective type families for Haskell" (HS'15). - -Now, it's very important to orient the equations this way round, -so that the fresh unification variable will be eliminated in -favour of alpha. If we instead had - [W] alpha ~ gamma1 -then we would unify alpha := gamma1; and kick out the wanted -constraint. But when we grough it back in, it'd look like - [W] TF (gamma1, beta) ~ fuv -and exactly the same thing would happen again! Infinite loop. - -This all seems fragile, and it might seem more robust to avoid -introducing gamma1 in the first place, in the case where the -actual argument (alpha, beta) partly matches the improvement -template. But that's a bit tricky, esp when we remember that the -kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new -equality with the template on the left. Delicate, but it works. - --} - -{- ******************************************************************* -* * - Top-level reaction for class constraints (CDictCan) -* * -**********************************************************************-} - -doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) --- Try to use type-class instance declarations to simplify the constraint -doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis }) - | isGiven ev -- Never use instances for Given constraints - = continueWith work_item - -- See Note [No Given/Given fundeps] - - | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached - = do { setEvBindIfWanted ev (ctEvTerm solved_ev) - ; stopWith ev "Dict/Top (cached)" } - - | otherwise -- Wanted, but not cached - = do { dflags <- getDynFlags - ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_res of - OneInst { cir_what = what } - -> do { insertSafeOverlapFailureTcS what work_item - ; addSolvedDict what ev cls xis - ; chooseInstance ev lkup_res } - _ -> -- NoInstance or NotSure - -- We didn't solve it; so try functional dependencies with - -- the instance environment - do { doTopFundepImprovement work_item - ; tryLastResortProhibitedSuperclass inerts work_item } } - where - dict_loc = ctEvLoc ev - - -doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) - --- | As a last resort, we TEMPORARILY allow a prohibited superclass solve, --- emitting a loud warning when doing so: we might be creating non-terminating --- evidence (as we are in T22912 for example). --- --- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance. -tryLastResortProhibitedSuperclass :: InertSet -> Ct -> TcS (StopOrContinue Ct) -tryLastResortProhibitedSuperclass inerts - work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = xis }) - | let loc_w = ctEvLoc ev_w - orig_w = ctLocOrigin loc_w - , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted - , Just ct_i <- lookupInertDict (inert_cans inerts) loc_w cls xis - , let ev_i = ctEvidence ct_i - , isGiven ev_i - = do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; ctLocWarnTcS loc_w $ - TcRnLoopySuperclassSolve loc_w (ctPred work_item) - ; return $ Stop ev_w (text "Loopy superclass") } -tryLastResortProhibitedSuperclass _ work_item - = continueWith work_item - -chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue Ct) -chooseInstance work_item - (OneInst { cir_new_theta = theta - , cir_what = what - , cir_mk_ev = mk_ev }) - = do { traceTcS "doTopReact/found instance for" $ ppr work_item - ; deeper_loc <- checkInstanceOK loc what pred - ; checkReductionDepth deeper_loc pred - ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar) - (ppr work_item) - ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta - ; setEvBindIfWanted work_item (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith work_item "Dict/Top (solved wanted)" } - where - pred = ctEvPred work_item - loc = ctEvLoc work_item - -chooseInstance work_item lookup_res - = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) - -checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc --- Check that it's OK to use this instance: --- (a) the use is well staged in the Template Haskell sense --- Returns the CtLoc to used for sub-goals --- Probably also want to call checkReductionDepth -checkInstanceOK loc what pred - = do { checkWellStagedDFun loc what pred - ; return deeper_loc } - where - deeper_loc = zap_origin (bumpCtLocDepth loc) - origin = ctLocOrigin loc - - zap_origin loc -- After applying an instance we can set ScOrigin to - -- NotNakedSc, so that prohibitedSuperClassSolve never fires - -- See Note [Solving superclass constraints] in - -- GHC.Tc.TyCl.Instance, (sc1). - | ScOrigin what _ <- origin - = setCtLocOrigin loc (ScOrigin what NotNakedSc) - | otherwise - = loc - -{- Note [Instances in no-evidence implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #15290 we had - [G] forall p q. Coercible p q => Coercible (m p) (m q)) - [W] forall a. m (Int, IntStateT m a) - ~R# - m (Int, StateT Int m a) - -The Given is an ordinary quantified constraint; the Wanted is an implication -equality that arises from - [W] (forall a. t1) ~R# (forall a. t2) - -But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) -we can't generate any term evidence. So we can't actually use that -lovely quantified constraint. Alas! - -This test arranges to ignore the instance-based solution under these -(rare) circumstances. It's sad, but I really don't see what else we can do. --} - - -matchClassInst :: DynFlags -> InertSet - -> Class -> [Type] - -> CtLoc -> TcS ClsInstResult -matchClassInst dflags inerts clas tys loc --- First check whether there is an in-scope Given that could --- match this constraint. In that case, do not use any instance --- whether top level, or local quantified constraints. --- See Note [Instance and Given overlap] - | not (xopt LangExt.IncoherentInstances dflags) - , not (naturallyCoherentClass clas) - , not (noMatchableGivenDicts inerts loc clas tys) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys ] - ; return NotSure } - - | otherwise - = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' - ; local_res <- matchLocalInst pred loc - ; case local_res of - OneInst {} -> -- See Note [Local instances and incoherence] - do { traceTcS "} matchClassInst local match" $ ppr local_res - ; return local_res } - - NotSure -> -- In the NotSure case for local instances - -- we don't want to try global instances - do { traceTcS "} matchClassInst local not sure" empty - ; return local_res } - - NoInstance -- No local instances, so try global ones - -> do { global_res <- matchGlobalInst dflags False clas tys - ; traceTcS "} matchClassInst global result" $ ppr global_res - ; return global_res } } - where - pred = mkClassPred clas tys - --- | If a class is "naturally coherent", then we needn't worry at all, in any --- way, about overlapping/incoherent instances. Just solve the thing! --- See Note [Naturally coherent classes] --- See also Note [The equality types story] in GHC.Builtin.Types.Prim. -naturallyCoherentClass :: Class -> Bool -naturallyCoherentClass cls - = isCTupleClass cls - || cls `hasKey` heqTyConKey - || cls `hasKey` eqTyConKey - || cls `hasKey` coercibleTyConKey - - -{- Note [Instance and Given overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example, from the OutsideIn(X) paper: - instance P x => Q [x] - instance (x ~ y) => R y [x] - - wob :: forall a b. (Q [b], R b a) => a -> Int - - g :: forall a. Q [a] => [a] -> Int - g x = wob x - -From 'g' we get the implication constraint: - forall a. Q [a] => (Q [beta], R beta [a]) -If we react (Q [beta]) with its top-level axiom, we end up with a -(P beta), which we have no way of discharging. On the other hand, -if we react R beta [a] with the top-level we get (beta ~ a), which -is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is -now solvable by the given Q [a]. - -The partial solution is that: - In matchClassInst (and thus in topReact), we return a matching - instance only when there is no Given in the inerts which is - unifiable to this particular dictionary. - - We treat any meta-tyvar as "unifiable" for this purpose, - *including* untouchable ones. But not skolems like 'a' in - the implication constraint above. - -The end effect is that, much as we do for overlapping instances, we -delay choosing a class instance if there is a possibility of another -instance OR a given to match our constraint later on. This fixes -tickets #4981 and #5002. - -Other notes: - -* The check is done *first*, so that it also covers classes - with built-in instance solving, such as - - constraint tuples - - natural numbers - - Typeable - -* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet. - -* The given-overlap problem is arguably not easy to appear in practice - due to our aggressive prioritization of equality solving over other - constraints, but it is possible. I've added a test case in - typecheck/should-compile/GivenOverlapping.hs - -* Another "live" example is #10195; another is #10177. - -* We ignore the overlap problem if -XIncoherentInstances is in force: - see #6002 for a worked-out example where this makes a - difference. - -* Moreover notice that our goals here are different than the goals of - the top-level overlapping checks. There we are interested in - validating the following principle: - - If we inline a function f at a site where the same global - instance environment is available as the instance environment at - the definition site of f then we should get the same behaviour. - - But for the Given Overlap check our goal is just related to completeness of - constraint solving. - -* The solution is only a partial one. Consider the above example with - g :: forall a. Q [a] => [a] -> Int - g x = let v = wob x - in v - and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most - general type for 'v'. When generalising v's type we'll simplify its - Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we - will use the instance declaration after all. #11948 was a case - in point. - -All of this is disgustingly delicate, so to discourage people from writing -simplifiable class givens, we warn about signatures that contain them; -see GHC.Tc.Validity Note [Simplifiable given constraints]. - -Note [Naturally coherent classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A few built-in classes are "naturally coherent". This term means that -the "instance" for the class is bidirectional with its superclass(es). -For example, consider (~~), which behaves as if it was defined like -this: - class a ~# b => a ~~ b - instance a ~# b => a ~~ b -(See Note [The equality types story] in GHC.Builtin.Types.Prim.) - -Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2, -without worrying about Note [Instance and Given overlap]. Why? Because -if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and -so the reduction of the [W] constraint does not risk losing any solutions. - -On the other hand, it can be fatal to /fail/ to reduce such -equalities, on the grounds of Note [Instance and Given overlap], -because many good things flow from [W] t1 ~# t2. - -The same reasoning applies to - -* (~~) heqTyCon -* (~) eqTyCon -* Coercible coercibleTyCon - -And less obviously to: - -* Tuple classes. For reasons described in GHC.Tc.Solver.Types - Note [Tuples hiding implicit parameters], we may have a constraint - [W] (?x::Int, C a) - with an exactly-matching Given constraint. We must decompose this - tuple and solve the components separately, otherwise we won't solve - it at all! It is perfectly safe to decompose it, because again the - superclasses invert the instance; e.g. - class (c1, c2) => (% c1, c2 %) - instance (c1, c2) => (% c1, c2 %) - Example in #14218 - -Examples: T5853, T10432, T5315, T9222, T2627b, T3028b - -PS: the term "naturally coherent" doesn't really seem helpful. -Perhaps "invertible" or something? I left it for now though. - -Note [Local instances and incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) - => c b -> Bool - f x = x==x - -We get [W] Eq (c b), and we must use the local instance to solve it. - -BUT that wanted also unifies with the top-level Eq [a] instance, -and Eq (Maybe a) etc. We want the local instance to "win", otherwise -we can't solve the wanted at all. So we mark it as Incohherent. -According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll -make it win even if there are other instances that unify. - -Moreover this is not a hack! The evidence for this local instance -will be constructed by GHC at a call site... from the very instances -that unify with it here. It is not like an incoherent user-written -instance which might have utterly different behaviour. - -Consider f :: Eq a => blah. If we have [W] Eq a, we certainly -get it from the Eq a context, without worrying that there are -lots of top-level instances that unify with [W] Eq a! We'll use -those instances to build evidence to pass to f. That's just the -nullary case of what's happening here. --} - -matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult --- Look up the predicate in Given quantified constraints, --- which are effectively just local instance declarations. -matchLocalInst pred loc - = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts - ; case match_local_inst inerts (inert_insts ics) of - { ([], []) -> do { traceTcS "No local instance for" (ppr pred) - ; return NoInstance } - ; (matches, unifs) -> - do { matches <- mapM mk_instDFun matches - ; unifs <- mapM mk_instDFun unifs - -- See Note [Use only the best matching quantified constraint] - ; case dominatingMatch matches of - { Just (dfun_id, tys, theta) - | all ((theta `impliedBySCs`) . thdOf3) unifs - -> - do { let result = OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = LocalInstance } - ; traceTcS "Best local instance found:" $ - vcat [ text "pred:" <+> ppr pred - , text "result:" <+> ppr result - , text "matches:" <+> ppr matches - , text "unifs:" <+> ppr unifs ] - ; return result } - - ; mb_best -> - do { traceTcS "Multiple local instances; not committing to any" - $ vcat [ text "pred:" <+> ppr pred - , text "matches:" <+> ppr matches - , text "unifs:" <+> ppr unifs - , text "best_match:" <+> ppr mb_best ] - ; return NotSure }}}}} - where - pred_tv_set = tyCoVarsOfType pred - - mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun - mk_instDFun (ev, tys) = - let dfun_id = ctEvEvId ev - in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys - ; return (dfun_id, tys, theta) } - - -- Compute matching and unifying local instances - match_local_inst :: InertSet - -> [QCInst] - -> ( [(CtEvidence, [DFunInstType])] - , [(CtEvidence, [DFunInstType])] ) - match_local_inst _inerts [] - = ([], []) - match_local_inst inerts (qci@(QCI { qci_tvs = qtvs - , qci_pred = qpred - , qci_ev = qev }) - :qcis) - | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) - , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) - emptyTvSubstEnv qpred pred - , let match = (qev, map (lookupVarEnv tv_subst) qtvs) - = (match:matches, unifs) - - | otherwise - = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred)) - (ppr qci $$ ppr pred) - -- ASSERT: unification relies on the - -- quantified variables being fresh - (matches, this_unif `combine` unifs) - where - qloc = ctEvLoc qev - qtv_set = mkVarSet qtvs - (matches, unifs) = match_local_inst inerts qcis - this_unif - | Just subst <- mightEqualLater inerts qpred qloc pred loc - = Just (qev, map (lookupTyVar subst) qtvs) - | otherwise - = Nothing - - combine Nothing us = us - combine (Just u) us = u : us - --- | Instance dictionary function and type. -type InstDFun = (DFunId, [TcType], TcThetaType) - --- | Try to find a local quantified instance that dominates all others, --- i.e. which has a weaker instance context than all the others. --- --- See Note [Use only the best matching quantified constraint]. -dominatingMatch :: [InstDFun] -> Maybe InstDFun -dominatingMatch matches = - listToMaybe $ mapMaybe (uncurry go) (holes matches) - -- listToMaybe: arbitrarily pick any one context that is weaker than - -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a] - -- (see test case T22223). - - where - go :: InstDFun -> [InstDFun] -> Maybe InstDFun - go this [] = Just this - go this@(_,_,this_theta) ((_,_,other_theta):others) - | this_theta `impliedBySCs` other_theta - = go this others - | otherwise - = Nothing - --- | Whether a collection of constraints is implied by another collection, --- according to a simple superclass check. --- --- See Note [When does a quantified instance dominate another?]. -impliedBySCs :: TcThetaType -> TcThetaType -> Bool -impliedBySCs c1 c2 = all in_c2 c1 - where - in_c2 :: TcPredType -> Bool - in_c2 pred = any (pred `tcEqType`) c2_expanded - - c2_expanded :: [TcPredType] -- Includes all superclasses - c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ] - - -{- Note [When does a quantified instance dominate another?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When matching local quantified instances, it's useful to be able to pick -the one with the weakest precondition, e.g. if one has both - - [G] d1: forall a b. ( Eq a, Num b, C a b ) => D a b - [G] d2: forall a . C a Int => D a Int - [W] {w}: D a Int - -Then it makes sense to use d2 to solve w, as doing so we end up with a strictly -weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)` -were we to use d1. - -In theory, to compute whether one context implies another, we would need to -recursively invoke the constraint solver. This is expensive, so we instead do -a simple check using superclasses, implemented in impliedBySCs. - -Examples: - - - [Eq a] is implied by [Ord a] - - [Ord a] is not implied by [Eq a], - - any context is implied by itself, - - the empty context is implied by any context. - -Note [Use only the best matching quantified constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#20582) the ambiguity check for - (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int - -Because of eager expansion of given superclasses, we get - [G] d1: forall a. Ord (m a) - [G] d2: forall a. Eq (m a) - [G] d3: forall a. Semigroup a => Eq (m a) - - [W] {w1}: forall a. Ord (m a) - [W] {w2}: forall a. Semigroup a => Eq (m a) - -The first wanted is solved straightforwardly. But the second wanted -matches *two* local instances: d2 and d3. Our general rule around multiple local -instances is that we refuse to commit to any of them. However, that -means that our type fails the ambiguity check. That's bad: the type -is perfectly fine. (This actually came up in the wild, in the streamly -library.) - -The solution is to prefer local instances which are easier to prove, meaning -that they have a weaker precondition. In this case, the empty context -of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer -using it when proving w2. This allows us to pass the ambiguity check here. - -Our criterion for solving a Wanted by matching local quantified instances is -thus as follows: - - - There is a matching local quantified instance that dominates all others - matches, in the sense of [When does a quantified instance dominate another?]. - Any such match do, we pick it arbitrarily (the T22223 example below says why). - - This local quantified instance also dominates all the unifiers, as we - wouldn't want to commit to a single match when we might have multiple, - genuinely different matches after further unification takes place. - -Some other examples: - - - #15244: - - f :: (C g, D g) => .... - class S g => C g where ... - class S g => D g where ... - class (forall a. Eq a => Eq (g a)) => S g where ... - - Here, in f's RHS, there are two identical quantified constraints - available, one via the superclasses of C and one via the superclasses - of D. Given that each implies the other, we pick one arbitrarily. - - - #22216: - - class Eq a - class Eq a => Ord a - class (forall b. Eq b => Eq (f b)) => Eq1 f - class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f - - Suppose we have - - [G] d1: Ord1 f - [G] d2: Eq a - [W] {w}: Eq (f a) - - Superclass expansion of d1 gives us: - - [G] d3 : Eq1 f - [G] d4 : forall b. Ord b => Ord (f b) - - expanding d4 and d5 gives us, respectively: - - [G] d5 : forall b. Eq b => Eq (f b) - [G] d6 : forall b. Ord b => Eq (f b) - - Now we have two matching local instances that we could use when solving the - Wanted. However, it's obviously silly to use d6, given that d5 provides us with - as much information, with a strictly weaker precondition. So we pick d5 to solve - w. If we chose d6, we would get [W] Ord a, which in this case we can't solve. - - - #22223: - - [G] forall a b. (Eq a, Ord b) => C a b - [G] forall a b. (Ord b, Eq a) => C a b - [W] C x y - - Here we should be free to pick either quantified constraint, as they are - equivalent up to re-ordering of the constraints in the context. - See also Note [Do not add duplicate quantified instances] - in GHC.Tc.Solver.Monad. - -Test cases: - typecheck/should_compile/T20582 - quantified-constraints/T15244 - quantified-constraints/T22216{a,b,c,d,e} - quantified-constraints/T22223 - -Historical note: a previous solution was to instead pick the local instance -with the least superclass depth (see Note [Replacement vs keeping]), -but that doesn't work for the example from #22216. --} diff --git a/compiler/GHC/Tc/Solver/Irred.hs b/compiler/GHC/Tc/Solver/Irred.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Irred.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Irred( + solveIrred + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence + +import GHC.Core.Coercion + +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Utils.Outputable + +import GHC.Data.Bag + +import Data.Void( Void ) + + +{- ********************************************************************* +* * +* Irreducibles +* * +********************************************************************* -} + +solveIrred :: IrredCt -> SolverStage Void +solveIrred irred + = do { simpleStage $ traceTcS "solveIrred:" (ppr irred) + ; tryInertIrreds irred + ; tryQCsIrredCt irred + ; simpleStage (updInertIrreds irred) + ; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" } + +updInertIrreds :: IrredCt -> TcS () +updInertIrreds irred + = do { tc_lvl <- getTcLevel + ; updInertCans $ addIrredToCans tc_lvl irred } + +{- ********************************************************************* +* * +* Inert Irreducibles +* * +********************************************************************* -} + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +tryInertIrreds :: IrredCt -> SolverStage () +tryInertIrreds irred + = Stage $ do { ics <- getInertCans + ; try_inert_irreds ics irred } + +try_inert_irreds :: InertCans -> IrredCt -> TcS (StopOrContinue ()) + +try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason }) + | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w + , ((irred_i, swap) : _rest) <- bagToList matching_irreds + -- See Note [Multiple matching irreds] + , let ev_i = irredCtEvidence irred_i + ct_i = CIrredCan irred_i + , not (isInsolubleReason reason) || isGiven ev_i || isGiven ev_w + -- See Note [Insoluble irreds] + = do { traceTcS "iteractIrred" $ + vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w)) + , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ] + ; case solveOneFromTheOther ct_i ct_w of + KeepInert -> do { setEvBindIfWanted ev_w True (swap_me swap ev_i) + ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } + KeepWork -> do { setEvBindIfWanted ev_i True (swap_me swap ev_w) + ; updInertCans (updIrreds (\_ -> others)) + ; continueWith () } } + + | otherwise + = continueWith () + + where + ct_w = CIrredCan irred_w + + swap_me :: SwapFlag -> CtEvidence -> EvTerm + swap_me swap ev + = case swap of + NotSwapped -> ctEvTerm ev + IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) + + +{- Note [Multiple matching irreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that it's impossible to have multiple irreds all match the +work item; after all, interactIrred looks for matches and solves one from the +other. However, note that interacting insoluble, non-droppable irreds does not +do this matching. We thus might end up with several insoluble, non-droppable, +matching irreds in the inert set. When another irred comes along that we have +not yet labeled insoluble, we can find multiple matches. These multiple matches +cause no harm, but it would be wrong to ASSERT that they aren't there (as we +once had done). This problem can be tickled by typecheck/should_compile/holes. + +Note [Insoluble irreds] +~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow an /insoluble/ Wanted to be solved from another identical +Wanted. We want to keep all the insoluble Wanteds distinct, so that we get +distinct error messages with -fdefer-type-errors + +However we /do/ allow an insoluble constraint (Given or Wanted) to be solved +from an identical insoluble Given. This might seem a little odd, but there is +lots of discussion in #23413 and #17543. We currently implement the PermissivePlan +of #23413. An alternative would be the LibertarianPlan, but that is harder to +implemnent. + +By "identical" we include swapping. See Note [Solving irreducible equalities] +in GHC.Tc.Solver.InertSet. + +Test cases that are involved bkpfail24.run, T15450, GivenForallLoop, T20189, T8392a. +-} + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +tryQCsIrredCt :: IrredCt -> SolverStage () +-- Try local quantified constraints for +-- and CIrredCan e.g. (c a) +tryQCsIrredCt (IrredCt { ir_ev = ev }) + | isGiven ev + = Stage $ continueWith () + + | otherwise + = Stage $ do { res <- matchLocalInst pred loc + ; case res of + OneInst {} -> chooseInstance ev res + _ -> continueWith () } + where + loc = ctEvLoc ev + pred = ctEvPred ev 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 @@ -19,2022 +19,2273 @@ runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS, emitImplicationTcS, emitTvImplicationTcS, - - selectNextWorkItem, - getWorkList, - updWorkListTcS, - pushLevelNoWorkList, - - runTcPluginTcS, recordUsedGREs, - matchGlobalInst, TcM.ClsInstResult(..), - - QCInst(..), - - -- Tracing etc - panicTcS, traceTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - resetUnificationFlag, setUnificationFlag, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvExpr, - - newTcEvBinds, newNoTcEvBinds, - newWantedEq, emitNewWantedEq, - newWanted, - newWantedNC, newWantedEvVarNC, - newBoundEvVarId, - unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..), - setEvBind, setWantedEq, - setWantedEvTerm, setEvBindIfWanted, - newEvVar, newGivenEvVar, newGivenEvVars, - checkReductionDepth, - getSolvedDicts, setSolvedDicts, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, setLclEnv, - getTcEvBindsVar, getTcLevel, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - tcLookupClass, tcLookupId, - - -- Inerts - updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getHasGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, getInnermostGivenEqLevel, - getTcSInerts, setTcSInerts, - getUnsolvedInerts, - removeInertCts, getPendingGivenScs, - addInertCan, insertFunEq, addInertForAll, - emitWorkNC, emitWork, - lookupInertDict, - - -- The Model - kickOutAfterUnification, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert solved dictionaries - addSolvedDict, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The family application cache - lookupFamAppInert, lookupFamAppCache, extendFamAppCache, - pprKicked, - - instDFunType, -- Instantiation - - -- MetaTyVars - newFlexiTcSTy, instFlexiX, - cloneMetaTyVar, - tcInstSkolTyVarsX, - - TcLevel, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, - zonkTyCoVarsAndFVList, - zonkSimples, zonkWC, - zonkTyCoVarKind, - - -- References - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- Misc - getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, matchFamTcM, - checkWellStagedDFun, - pprEq, -- Smaller utils, re-exported from TcM - -- TODO (DV): these are only really used in the - -- instance matcher in GHC.Tc.Solver. I am wondering - -- if the whole instance matcher simply belongs - -- here - - breakTyEqCycle_maybe, rewriterView -) where - -import GHC.Prelude - -import GHC.Driver.Env - -import qualified GHC.Tc.Utils.Instantiate as TcM -import GHC.Core.InstEnv -import GHC.Tc.Instance.Family as FamInst -import GHC.Core.FamInstEnv - -import qualified GHC.Tc.Utils.Monad as TcM -import qualified GHC.Tc.Utils.TcMType as TcM -import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) -import qualified GHC.Tc.Utils.Env as TcM - ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl - , tcInitTidyEnv ) - -import GHC.Driver.Session - -import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) -import GHC.Tc.Utils.TcType -import GHC.Tc.Solver.Types -import GHC.Tc.Solver.InertSet -import GHC.Tc.Types.Evidence -import GHC.Tc.Errors.Types - -import GHC.Core.Type -import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very locally -import GHC.Core.Coercion -import GHC.Core.Reduction -import GHC.Core.Class -import GHC.Core.TyCon - -import GHC.Types.Error ( mkPlainError, noHints ) -import GHC.Types.Name -import GHC.Types.TyThing -import GHC.Types.Name.Reader - -import GHC.Unit.Module ( HasModule, getModule, extractModule ) -import qualified GHC.Rename.Env as TcM -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Logger -import GHC.Utils.Misc (HasDebugCallStack) -import GHC.Data.Bag as Bag -import GHC.Types.Unique.Supply -import GHC.Tc.Types -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.Unify -import GHC.Core.Predicate -import GHC.Types.Unique.Set (nonDetEltsUniqSet) - -import Control.Monad -import GHC.Utils.Monad -import Data.IORef -import GHC.Exts (oneShot) -import Data.List ( mapAccumL, partition ) -import Data.Foldable - -#if defined(DEBUG) -import GHC.Data.Graph.Directed -#endif - -{- ********************************************************************* -* * - Inert instances: inert_insts -* * -********************************************************************* -} - -addInertForAll :: QCInst -> TcS () --- Add a local Given instance, typically arising from a type signature -addInertForAll new_qci - = do { ics <- getInertCans - ; ics1 <- add_qci ics - - -- Update given equalities. C.f updateGivenEqs - ; tclvl <- getTcLevel - ; let pred = qci_pred new_qci - not_equality = isClassPred pred && not (isEqPred pred) - -- True <=> definitely not an equality - -- A qci_pred like (f a) might be an equality - - ics2 | not_equality = ics1 - | otherwise = ics1 { inert_given_eq_lvl = tclvl - , inert_given_eqs = True } - - ; setInertCans ics2 } - where - add_qci :: InertCans -> TcS InertCans - -- See Note [Do not add duplicate quantified instances] - add_qci ics@(IC { inert_insts = qcis }) - | any same_qci qcis - = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) - ; return ics } - - | otherwise - = do { traceTcS "adding new inert quantified instance" (ppr new_qci) - ; return (ics { inert_insts = new_qci : qcis }) } - - same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) - (ctEvPred (qci_ev new_qci)) - -{- Note [Do not add duplicate quantified instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As an optimisation, we avoid adding duplicate quantified instances to the -inert set; we use a simple duplicate check using tcEqType for simplicity, -even though it doesn't account for superficial differences, e.g. it will count -the following two constraints as different (#22223): - - - forall a b. C a b - - forall b a. C a b - -The main logic that allows us to pick local instances, even in the presence of -duplicates, is explained in Note [Use only the best matching quantified constraint] -in GHC.Tc.Solver.Interact. --} - -{- ********************************************************************* -* * - Adding an inert -* * -************************************************************************ - -Note [Adding an equality to the InertCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality to the inerts: - -* Kick out any constraints that can be rewritten by the thing - we are adding. Done by kickOutRewritable. - -* Note that unifying a:=ty, is like adding [G] a~ty; just use - kickOutRewritable with Nominal, Given. See kickOutAfterUnification. - -Note [Kick out existing binding for implicit parameter] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (typecheck/should_compile/ImplicitParamFDs) - flub :: (?x :: Int) => (Int, Integer) - flub = (?x, let ?x = 5 in ?x) -When we are checking the last ?x occurrence, we guess its type -to be a fresh unification variable alpha and emit an (IP "x" alpha) -constraint. But the given (?x :: Int) has been translated to an -IP "x" Int constraint, which has a functional dependency from the -name to the type. So fundep interaction tells us that alpha ~ Int, -and we get a type error. This is bad. - -Instead, we wish to excise any old given for an IP when adding a -new one. We also must make sure not to float out -any IP constraints outside an implication that binds an IP of -the same name; see GHC.Tc.Solver.floatConstraints. --} - -addInertCan :: Ct -> TcS () --- Precondition: item /is/ canonical --- See Note [Adding an equality to the InertCans] -addInertCan ct = - do { traceTcS "addInertCan {" $ - text "Trying to insert new inert item:" <+> ppr ct - ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} -> - when (abort_flag && insolubleEqCt ct) TcM.failM) - ; ics <- getInertCans - ; ics <- maybeKickOut ics ct - ; tclvl <- getTcLevel - ; setInertCans (addInertItem tclvl ics ct) - - ; traceTcS "addInertCan }" $ empty } - -maybeKickOut :: InertCans -> Ct -> TcS InertCans --- For a CEqCan, kick out any inert that can be rewritten by the CEqCan -maybeKickOut ics ct - | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct - = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics - ; return ics' } - - -- See [Kick out existing binding for implicit parameter] - | isGivenCt ct - , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct - , isIPClass cls - , Just ip_name <- isStrLitTy ip_name_strty - -- Would this be more efficient if we used findDictsByClass and then delDict? - = let dict_map = inert_dicts ics - dict_map' = filterDicts doesn't_match_ip_name dict_map - - doesn't_match_ip_name :: Ct -> Bool - doesn't_match_ip_name ct - | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct) - = inert_ip_name /= ip_name - - | otherwise - = True - - in - return (ics { inert_dicts = dict_map' }) - - | otherwise - = return ics - ------------------------------------------ -kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> CanEqLHS -- The new equality is lhs ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_lhs ics - = do { let (kicked_out, ics') = kickOutRewritableLHS new_fr new_lhs ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - - -- The famapp-cache contains Given evidence from the inert set. - -- If we're kicking out Givens, we need to remove this evidence - -- from the cache, too. - ; let kicked_given_ev_vars = - [ ev_var | ct <- wl_eqs kicked_out - , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ] - ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && - -- if this isn't true, no use looking through the constraints - not (null kicked_given_ev_vars)) $ - do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" - (ppr kicked_given_ev_vars) - ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) } - - ; csTraceTcS $ - hang (text "Kick out, lhs =" <+> ppr new_lhs) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; return (n_kicked, ics') } - -kickOutAfterUnification :: TcTyVar -> TcS Int -kickOutAfterUnification new_tv - = do { ics <- getInertCans - ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - (TyVarLHS new_tv) ics - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - ; setInertCans ics2 - ; return n_kicked } - --- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical --- It's possible that this could just go ahead and unify, but could there be occurs-check --- problems? Seems simpler just to kick out. -kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () -kickOutAfterFillingCoercionHole hole - = do { ics <- getInertCans - ; let (kicked_out, ics') = kick_out ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, hole =" <+> ppr hole) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; setInertCans ics' } - where - kick_out :: InertCans -> (WorkList, InertCans) - kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs }) - = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep }) - where - (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_ct eqs - (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs - kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList - - kick_ct :: Ct -> Bool - -- True: kick out; False: keep. - kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev }) - = isWanted ctev && -- optimisation: givens don't have coercion holes anyway - rhs `hasThisCoercionHoleTy` hole - kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other) - --------------- -addInertSafehask :: InertCans -> Ct -> InertCans -addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } - -addInertSafehask _ item - = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item - -insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS () --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -insertSafeOverlapFailureTcS what item - | safeOverlap what = return () - | otherwise = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS Cts --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -getSafeOverlapFailures - = do { IC { inert_safehask = safehask } <- getInertCans - ; return $ foldDicts consCts safehask emptyCts } - --------------- -addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS () --- Conditionally add a new item in the solved set of the monad --- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet -addSolvedDict what item cls tys - | isWanted item - , instanceReturnsDictCon what - = do { traceTcS "updSolvedSetTcs:" $ ppr item - ; updInertTcS $ \ ics -> - ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } - | otherwise - = return () - -getSolvedDicts :: TcS (DictMap CtEvidence) -getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) } - -setSolvedDicts :: DictMap CtEvidence -> TcS () -setSolvedDicts solved_dicts - = updInertTcS $ \ ics -> - ics { inert_solved_dicts = solved_dicts } - -{- ********************************************************************* -* * - Other inert-set operations -* * -********************************************************************* -} - -updInertTcS :: (InertSet -> InertSet) -> TcS () --- Modify the inert set with the supplied function -updInertTcS upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } - -getInertCans :: TcS InertCans -getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } - -setInertCans :: InertCans -> TcS () -setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } - -updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a --- Modify the inert set with the supplied function -updRetInertCans upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { inerts <- TcM.readTcRef is_var - ; let (res, cans') = upd_fn (inert_cans inerts) - ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) - ; return res }) } - -updInertCans :: (InertCans -> InertCans) -> TcS () --- Modify the inert set with the supplied function -updInertCans upd_fn - = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } - -updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertDicts upd_fn - = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } - -updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertSafehask upd_fn - = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } - -updInertIrreds :: (Cts -> Cts) -> TcS () --- Modify the inert set with the supplied function -updInertIrreds upd_fn - = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } - -getInertEqs :: TcS InertEqs -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInnermostGivenEqLevel :: TcS TcLevel -getInnermostGivenEqLevel = do { inert <- getInertCans - ; return (inert_given_eq_lvl inert) } - -getInertInsols :: TcS Cts --- Returns insoluble equality constraints and TypeError constraints, --- specifically including Givens. --- --- Note that this function only inspects irreducible constraints; --- a DictCan constraint such as 'Eq (TypeError msg)' is not --- considered to be an insoluble constraint by this function. --- --- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. -getInertInsols = do { inert <- getInertCans - ; return $ filterBag insolubleCt (inert_irreds inert) } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldIrreds (:) (inert_irreds inerts) - $ foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (++) (inert_funeqs inerts) - $ foldDVarEnv (++) [] (inert_eqs inerts) - ; return (filter isGivenCt all_cts) } - -getPendingGivenScs :: TcS [Ct] --- Find all inert Given dictionaries, or quantified constraints, --- whose cc_pend_sc flag is True --- and that belong to the current level --- Set their cc_pend_sc flag to False in the inert set, and return that Ct -getPendingGivenScs = do { lvl <- getTcLevel - ; updRetInertCans (get_sc_pending lvl) } - -get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) -get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) - = assertPpr (all isGivenCt sc_pending) (ppr sc_pending) - -- When getPendingScDics is called, - -- there are never any Wanteds in the inert set - (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) - where - sc_pending = sc_pend_insts ++ sc_pend_dicts - - sc_pend_dicts = foldDicts get_pending dicts [] - dicts' = foldr add dicts sc_pend_dicts - - (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts - - get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True - -- but flipping the flag - get_pending dict dicts - | Just dict' <- pendingScDict_maybe dict - , belongs_to_this_level (ctEvidence dict) - = dict' : dicts - | otherwise - = dicts - - add :: Ct -> DictMap Ct -> DictMap Ct - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDict dicts cls tys ct - add ct _ = pprPanic "getPendingScDicts" (ppr ct) - - get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) - get_pending_inst cts qci@(QCI { qci_ev = ev }) - | Just qci' <- pendingScInst_maybe qci - , belongs_to_this_level ev - = (CQuantCan qci' : cts, qci') - | otherwise - = (cts, qci) - - belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl - -- We only want Givens from this level; see (3a) in - -- Note [The superclass story] in GHC.Tc.Solver.Canonical - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts ) -- All simple constraints --- Return all the unsolved [Wanted] constraints --- --- Post-condition: the returned simple constraints are all fully zonked --- (because they come from the inert set) --- the unsolved implics may not be -getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts - } <- getInertCans - - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts - unsolved_irreds = Bag.filterBag isWantedCt irreds - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unionManyBags [ unsolved_irreds - , unsolved_dicts ] - - ; implics <- getWorkListImplics - - ; traceTcS "getUnsolvedInerts" $ - vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs - , text "fun eqs =" <+> ppr unsolved_fun_eqs - , text "others =" <+> ppr unsolved_others - , text "implics =" <+> ppr implics ] - - ; return ( implics, unsolved_tv_eqs `unionBags` - unsolved_fun_eqs `unionBags` - unsolved_others) } - where - add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - - add_if_unsolveds :: EqualCtList -> Cts -> Cts - add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts - -getHasGivenEqs :: TcLevel -- TcLevel of this implication - -> TcS ( HasGivenEqs -- are there Given equalities? - , Cts ) -- Insoluble equalities arising from givens --- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet -getHasGivenEqs tclvl - = do { inerts@(IC { inert_irreds = irreds - , inert_given_eqs = given_eqs - , inert_given_eq_lvl = ge_lvl }) - <- getInertCans - ; let given_insols = filterBag insoluble_given_equality irreds - -- Specifically includes ones that originated in some - -- outer context but were refined to an insoluble by - -- a local equality; so no level-check needed - - -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and - -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet - has_ge | ge_lvl == tclvl = MaybeGivenEqs - | given_eqs = LocalGivenEqs - | otherwise = NoGivenEqs - - ; traceTcS "getHasGivenEqs" $ - vcat [ text "given_eqs:" <+> ppr given_eqs - , text "ge_lvl:" <+> ppr ge_lvl - , text "ambient level:" <+> ppr tclvl - , text "Inerts:" <+> ppr inerts - , text "Insols:" <+> ppr given_insols] - ; return (has_ge, given_insols) } - where - insoluble_given_equality ct - = insolubleEqCt ct && isGivenCt ct - -removeInertCts :: [Ct] -> InertCans -> InertCans --- ^ Remove inert constraints from the 'InertCans', for use when a --- typechecker plugin wishes to discard a given. -removeInertCts cts icans = foldl' removeInertCt icans cts - -removeInertCt :: InertCans -> Ct -> InertCans -removeInertCt is ct = - case ct of - - CDictCan { cc_class = cl, cc_tyargs = tys } -> - is { inert_dicts = delDict (inert_dicts is) cl tys } - - CEqCan { cc_lhs = lhs, cc_rhs = rhs } -> delEq is lhs rhs - - CIrredCan {} -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is } - - CQuantCan {} -> panic "removeInertCt: CQuantCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - -eqCt :: Ct -> Ct -> Bool --- Equality via ctEvId -eqCt c c' = ctEvId c == ctEvId c' - --- | Looks up a family application in the inerts. -lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? - -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) -lookupFamAppInert rewrite_pred fam_tc tys - = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (lookup_inerts inert_funeqs) } - where - lookup_inerts inert_funeqs - | Just ecl <- findFunEq inert_funeqs fam_tc tys - , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs }) - <- find (rewrite_pred . ctFlavourRole) ecl - = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev) - | otherwise = Nothing - -lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) --- Is this exact predicate type cached in the solved or canonicals of the InertSet? -lookupInInerts loc pty - | ClassPred cls tys <- classifyPredType pty - = do { inerts <- getTcSInerts - ; let mb_solved = lookupSolvedDict inerts loc cls tys - mb_inert = fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys) - ; return $ do -- Maybe monad - found_ev <- mb_solved `mplus` mb_inert - - -- We're about to "solve" the wanted we're looking up, so we - -- must make sure doing so wouldn't run afoul of - -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - -- Forgetting this led to #20666. - guard $ not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc) - - return found_ev } - | otherwise -- NB: No caching for equalities, IPs, holes, or errors - = return Nothing - --- | Look up a dictionary inert. -lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct -lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = case findDict dicts loc cls tys of - Just ct -> Just ct - _ -> Nothing - --- | Look up a solved inert. -lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence --- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys - = case findDict solved loc cls tys of - Just ev -> Just ev - _ -> Nothing - ---------------------------- -lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction) -lookupFamAppCache fam_tc tys - = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts - ; case findFunEq famapp_cache fam_tc tys of - result@(Just redn) -> - do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys) - , ppr redn ]) - ; return result } - Nothing -> return Nothing } - -extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS () --- NB: co :: rhs ~ F tys, to match expectations of rewriter -extendFamAppCache tc xi_args stuff@(Reduction _ ty) - = do { dflags <- getDynFlags - ; when (gopt Opt_FamAppCache dflags) $ - do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args - , ppr ty ]) - ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) -> - is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } - --- Remove entries from the cache whose evidence mentions variables in the --- supplied set -dropFromFamAppCache :: VarSet -> TcS () -dropFromFamAppCache varset - = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts - ; let filtered = filterTcAppMap check famapp_cache - ; setTcSInerts $ inerts { inert_famapp_cache = filtered } } - where - check :: Reduction -> Bool - check redn - = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) - -{- ********************************************************************* -* * - Irreds -* * -********************************************************************* -} - -foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b -foldIrreds k irreds z = foldr k z irreds - -{- -************************************************************************ -* * -* The TcS solver monad * -* * -************************************************************************ - -Note [The TcS monad] -~~~~~~~~~~~~~~~~~~~~ -The TcS monad is a weak form of the main Tc monad - -All you can do is - * fail - * allocate new variables - * fill in evidence variables - -Filling in a dictionary evidence variable means to create a binding -for it, so TcS carries a mutable location where the binding can be -added. This is initialised from the innermost implication constraint. --} - -data TcSEnv - = TcSEnv { - tcs_ev_binds :: EvBindsVar, - - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero - - tcs_unif_lvl :: IORef (Maybe TcLevel), - -- The Unification Level Flag - -- Outermost level at which we have unified a meta tyvar - -- Starts at Nothing, then (Just i), then (Just j) where j TcM a } - deriving (Functor) - -instance MonadFix TcS where - mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) - --- | Smart constructor for 'TcS', as describe in Note [The one-shot state --- monad trick] in "GHC.Utils.Monad". -mkTcS :: (TcSEnv -> TcM a) -> TcS a -mkTcS f = TcS (oneShot f) - -instance Applicative TcS where - pure x = mkTcS $ \_ -> return x - (<*>) = ap - -instance Monad TcS where - m >>= k = mkTcS $ \ebs -> do - unTcS m ebs >>= (\r -> unTcS (k r) ebs) - -instance MonadIO TcS where - liftIO act = TcS $ \_env -> liftIO act - -instance MonadFail TcS where - fail err = mkTcS $ \_ -> fail err - -instance MonadUnique TcS where - getUniqueSupplyM = wrapTcS getUniqueSupplyM - -instance HasModule TcS where - getModule = wrapTcS getModule - -instance MonadThings TcS where - lookupThing n = wrapTcS (lookupThing n) - --- Basic functionality --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -wrapTcS :: TcM a -> TcS a --- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, --- and TcS is supposed to have limited functionality -wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds - -wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a -wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env) - -wrapErrTcS :: TcM a -> TcS a --- The thing wrapped should just fail --- There's no static check; it's up to the user --- Having a variant for each error message is too painful -wrapErrTcS = wrapTcS - -wrapWarnTcS :: TcM a -> TcS a --- The thing wrapped should just add a warning, or no-op --- There's no static check; it's up to the user -wrapWarnTcS = wrapTcS - -panicTcS :: SDoc -> TcS a -failTcS :: TcRnMessage -> TcS a -warnTcS, addErrTcS :: TcRnMessage -> TcS () -failTcS = wrapTcS . TcM.failWith -warnTcS msg = wrapTcS (TcM.addDiagnostic msg) -addErrTcS = wrapTcS . TcM.addErr -panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc - --- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'. -ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS () -ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg - -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 = wrapTcS . runTcPluginM - -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags - -getGlobalRdrEnvTcS :: TcS GlobalRdrEnv -getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv - -bumpStepCountTcS :: TcS () -bumpStepCountTcS = mkTcS $ \env -> - do { let ref = tcs_count env - ; n <- TcM.readTcRef ref - ; TcM.writeTcRef ref (n+1) } - -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 -traceFireTcS ev doc - = mkTcS $ \env -> csTraceTcM $ - do { n <- TcM.readTcRef (tcs_count env) - ; tclvl <- TcM.getTcLevel - ; return (hang (text "Step" <+> int n - <> brackets (text "l:" <> ppr tclvl <> comma <> - 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 -csTraceTcM mk_doc - = do { logger <- getLogger - ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace - || logHasDumpFlag logger Opt_D_dump_tc_trace) - ( do { msg <- mk_doc - ; TcM.dumpTcRn False - Opt_D_dump_cs_trace - "" FormatText - msg }) } -{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] - -runTcS :: TcS a -- What to run - -> TcM (a, EvBindMap) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; return (res, ev_binds) } - --- | This variant of 'runTcS' will immediately fail upon encountering an --- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage --- site does not need the ev_binds, so we do not return them. -runTcSEarlyAbort :: TcS a -> TcM a -runTcSEarlyAbort tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds' True True ev_binds_var tcs } - --- | This can deal only with equality constraints. -runTcSEqualities :: TcS a -> TcM a -runTcSEqualities thing_inside - = do { ev_binds_var <- TcM.newNoTcEvBinds - ; runTcSWithEvBinds ev_binds_var thing_inside } - --- | A variant of 'runTcS' that takes and returns an 'InertSet' for --- later resumption of the 'TcS' session. -runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) -runTcSInerts inerts tcs = do - ev_binds_var <- TcM.newTcEvBinds - runTcSWithEvBinds' False False ev_binds_var $ do - setTcSInerts inerts - a <- tcs - new_inerts <- getTcSInerts - return (a, new_inerts) - -runTcSWithEvBinds :: EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds = runTcSWithEvBinds' True False - -runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards? - -- Don't if you want to reuse the InertSet. - -- See also Note [Type equality cycles] - -- in GHC.Tc.Solver.Canonical - -> Bool - -> EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs - = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList - ; unif_lvl_var <- TcM.newTcRef Nothing - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_unif_lvl = unif_lvl_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_abort_on_insoluble = abort_on_insoluble - , tcs_worklist = wl_var } - - -- Run the computation - ; res <- unTcS tcs env - - ; count <- TcM.readTcRef step_count - ; when (count > 0) $ - csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - - ; when restore_cycles $ - do { inert_set <- TcM.readTcRef inert_var - ; restoreTyVarCycles inert_set } - -#if defined(DEBUG) - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; checkForCyclicBinds ev_binds -#endif - - ; return res } - ----------------------------- -#if defined(DEBUG) -checkForCyclicBinds :: EvBindMap -> TcM () -checkForCyclicBinds ev_binds_map - | null cycles - = return () - | null coercion_cycles - = TcM.traceTc "Cycle in evidence binds" $ ppr cycles - | otherwise - = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles - where - ev_binds = evBindMapBinds ev_binds_map - - cycles :: [[EvBind]] - cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] - - coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b) - - edges :: [ Node EvVar EvBind ] - edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs)) - | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. -#endif - ----------------------------- -setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a -setEvBindsTcS ref (TcS thing_inside) - = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) - -nestImplicTcS :: EvBindsVar - -> TcLevel -> TcS a - -> TcS a -nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - , tcs_unif_lvl = unif_lvl - , tcs_abort_on_insoluble = abort_on_insoluble - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack - (inert_cycle_breakers inerts) - , inert_cans = (inert_cans inerts) - { inert_given_eqs = False } } - -- All other InertSet fields are inherited - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_count = count -- Inherited - , tcs_unif_lvl = unif_lvl -- Inherited - , tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_inerts = new_inert_var - , tcs_abort_on_insoluble = abort_on_insoluble - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env - - ; out_inert_set <- TcM.readTcRef new_inert_var - ; restoreTyVarCycles out_inert_set - -#if defined(DEBUG) - -- Perform a check that the thing_inside did not cause cycles - ; ev_binds <- TcM.getTcEvBindsMap ref - ; checkForCyclicBinds ev_binds -#endif - ; return res } - -nestTcS :: TcS a -> TcS a --- Use the current untouchables, augmenting the current --- evidence bindings, and solved dictionaries --- But have no effect on the InertCans, or on the inert_famapp_cache --- (we want to inherit the latter from processing the Givens) -nestTcS (TcS thing_inside) - = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> - do { inerts <- TcM.readTcRef inerts_var - ; new_inert_var <- TcM.newTcRef inerts - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - - ; res <- thing_inside nest_env - - ; new_inerts <- TcM.readTcRef new_inert_var - - -- we want to propagate the safe haskell failures - ; let old_ic = inert_cans inerts - new_ic = inert_cans new_inerts - nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } - - ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] - (inerts { inert_solved_dicts = inert_solved_dicts new_inerts - , inert_cans = nxt_ic }) - - ; return res } - -emitImplicationTcS :: TcLevel -> SkolemInfoAnon - -> [TcTyVar] -- Skolems - -> [EvVar] -- Givens - -> Cts -- Wanteds - -> TcS TcEvBinds --- Add an implication to the TcS monad work-list -emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_given = givens - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp - ; return (TcEvBinds (ic_binds imp)) } - -emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon - -> [TcTyVar] -- Skolems - -> Cts -- Wanteds - -> TcS () --- Just like emitImplicationTcS but no givens and no bindings -emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newNoTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp } - - -{- Note [Propagate the solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really quite important that nestTcS does not discard the solved -dictionaries from the thing_inside. -Consider - Eq [a] - forall b. empty => Eq [a] -We solve the simple (Eq [a]), under nestTcS, and then turn our attention to -the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a significant performance difference -if you do so. --} - --- Getters and setters of GHC.Tc.Utils.Env fields --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- Getter of inerts and worklist -getTcSInertsRef :: TcS (IORef InertSet) -getTcSInertsRef = TcS (return . tcs_inerts) - -getTcSWorkListRef :: TcS (IORef WorkList) -getTcSWorkListRef = TcS (return . tcs_worklist) - -getTcSInerts :: TcS InertSet -getTcSInerts = getTcSInertsRef >>= readTcRef - -setTcSInerts :: InertSet -> TcS () -setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics } - -getWorkListImplics :: TcS (Bag Implication) -getWorkListImplics - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- readTcRef wl_var - ; return (wl_implics wl_curr) } - -pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) --- Push the level and run thing_inside --- However, thing_inside should not generate any work items -#if defined(DEBUG) -pushLevelNoWorkList err_doc (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM $ - thing_inside (env { tcs_worklist = wl_panic }) - ) - where - wl_panic = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc - -- This panic checks that the thing-inside - -- does not emit any work-list constraints -#else -pushLevelNoWorkList _ (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check -#endif - -updWorkListTcS :: (WorkList -> WorkList) -> TcS () -updWorkListTcS f - = do { wl_var <- getTcSWorkListRef - ; updTcRef wl_var f } - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs - = return () - | otherwise - = emitWork (map mkNonCanonical evs) - -emitWork :: [Ct] -> TcS () -emitWork [] = return () -- avoid printing, among other work -emitWork cts - = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) - ; updWorkListTcS (extendWorkListCts cts) } - -emitImplication :: Implication -> TcS () -emitImplication implic - = updWorkListTcS (extendWorkListImplic implic) - -newTcRef :: a -> TcS (TcRef a) -newTcRef x = wrapTcS (TcM.newTcRef x) - -readTcRef :: TcRef a -> TcS a -readTcRef ref = wrapTcS (TcM.readTcRef ref) - -writeTcRef :: TcRef a -> a -> TcS () -writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) - -updTcRef :: TcRef a -> (a->a) -> TcS () -updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) - -getTcEvBindsVar :: TcS EvBindsVar -getTcEvBindsVar = TcS (return . tcs_ev_binds) - -getTcLevel :: TcS TcLevel -getTcLevel = wrapTcS TcM.getTcLevel - -getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet -getTcEvTyCoVars ev_binds_var - = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var - -getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap -getTcEvBindsMap ev_binds_var - = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () -setTcEvBindsMap ev_binds_var binds - = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds - -unifyTyVar :: TcTyVar -> TcType -> TcS () --- Unify a meta-tyvar with a type --- We keep track of how many unifications have happened in tcs_unified, --- --- We should never unify the same variable twice! -unifyTyVar tv ty - = assertPpr (isMetaTyVar tv) (ppr tv) $ - TcS $ \ env -> - do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty - ; TcM.updTcRef (tcs_unified env) (+1) } - -reportUnifications :: TcS a -> TcS (Int, a) -reportUnifications (TcS thing_inside) - = TcS $ \ env -> - do { inner_unified <- TcM.newTcRef 0 - ; res <- thing_inside (env { tcs_unified = inner_unified }) - ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) - ; return (n_unifs, res) } - -data TouchabilityTestResult - -- See Note [Solve by unification] in GHC.Tc.Solver.Interact - -- which points out that having TouchableSameLevel is just an optimisation; - -- we could manage with TouchableOuterLevel alone (suitably renamed) - = TouchableSameLevel - | TouchableOuterLevel [TcTyVar] -- Promote these - TcLevel -- ..to this level - | Untouchable - -instance Outputable TouchabilityTestResult where - ppr TouchableSameLevel = text "TouchableSameLevel" - ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs) - ppr Untouchable = text "Untouchable" - -touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType) --- ^ This is the key test for untouchability: --- See Note [Unification preconditions] in GHC.Tc.Utils.Unify --- and Note [Solve by unification] in GHC.Tc.Solver.Interact --- --- Returns a new rhs type, as this function can turn make some metavariables concrete. -touchabilityTest flav tv1 rhs - | flav /= Given -- See Note [Do not unify Givens] - , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1 - = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs - ; case continue_solving of - { Nothing -> return (Untouchable, rhs) - ; Just rhs -> - do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $ - nonDetEltsUniqSet $ - tyCoVarsOfType rhs - ; ambient_lvl <- getTcLevel - ; given_eq_lvl <- getInnermostGivenEqLevel - - ; if | tv_lvl `sameDepthAs` ambient_lvl - -> return (TouchableSameLevel, rhs) - - | tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities - , all (does_not_escape tv_lvl) free_skols -- No skolem escapes - -> return (TouchableOuterLevel free_metas tv_lvl, rhs) - - | otherwise - -> return (Untouchable, rhs) } } } - | otherwise - = return (Untouchable, rhs) - where - - does_not_escape tv_lvl fv - | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv - | otherwise = True - -- Coercion variables are not an escape risk - -- If an implication binds a coercion variable, it'll have equalities, - -- so the "intervening given equalities" test above will catch it - -- Coercion holes get filled with coercions, so again no problem. - -{- Note [Do not unify Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GADT match - data T a where - T1 :: T Int - ... - - f x = case x of - T1 -> True - ... - -So we get f :: T alpha[1] -> beta[1] - x :: T alpha[1] -and from the T1 branch we get the implication - forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool - -Now, clearly we don't want to unify alpha:=Int! Yet at the moment we -process [G] alpha[1] ~ Int, we don't have any given-equalities in the -inert set, and hence there are no given equalities to make alpha untouchable. - -NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that -never happens: invariant (GivenInv) in Note [TcLevel invariants] -in GHC.Tc.Utils.TcType. - -Simple solution: never unify in Givens! --} - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - -getWorkList :: TcS WorkList -getWorkList = do { wl_var <- getTcSWorkListRef - ; wrapTcS (TcM.readTcRef wl_var) } - -selectNextWorkItem :: TcS (Maybe Ct) --- Pick which work item to do next --- See Note [Prioritise equalities] -selectNextWorkItem - = do { wl_var <- getTcSWorkListRef - ; wl <- readTcRef wl_var - ; case selectWorkItem wl of { - Nothing -> return Nothing ; - Just (ct, new_wl) -> - do { -- checkReductionDepth (ctLoc ct) (ctPred ct) - -- This is done by GHC.Tc.Solver.Interact.chooseInstance - ; writeTcRef wl_var new_wl - ; return (Just ct) } } } - --- Just get some environments needed for instance looking up and matching --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getInstEnvs :: TcS InstEnvs -getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs - -getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) -getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs - -getTopEnv :: TcS HscEnv -getTopEnv = wrapTcS $ TcM.getTopEnv - -getGblEnv :: TcS TcGblEnv -getGblEnv = wrapTcS $ TcM.getGblEnv - -getLclEnv :: TcS TcLclEnv -getLclEnv = wrapTcS $ TcM.getLclEnv - -setLclEnv :: TcLclEnv -> TcS a -> TcS a -setLclEnv env = wrap2TcS (TcM.setLclEnv env) - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId n - --- Any use of this function is a bit suspect, because it violates the --- pure veneer of TcS. But it's just about warnings around unused imports --- and local constructors (GHC will issue fewer warnings than it otherwise --- might), so it's not worth losing sleep over. -recordUsedGREs :: Bag GlobalRdrElt -> TcS () -recordUsedGREs gres - = do { wrapTcS $ TcM.addUsedGREs gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; wrapTcS $ traverse_ (TcM.keepAlive . greMangledName) gre_list } - -- ...and similarly, if a newtype constructor was defined in the same - -- module, don't warn about it being unused. - -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. - - where - gre_list = bagToList gres - --- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () --- Check that we do not try to use an instance before it is available. E.g. --- instance Eq T where ... --- f x = $( ... (\(p::T) -> p == p)... ) --- Here we can't use the equality function from the instance in the splice - -checkWellStagedDFun loc what pred - = do - mbind_lvl <- checkWellStagedInstanceWhat what - case mbind_lvl of - Just bind_lvl | bind_lvl > impLevel -> - wrapTcS $ TcM.setCtLocM loc $ do - { use_stage <- TcM.getStage - ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } - _ -> - return () - where - pp_thing = text "instance for" <+> quotes (ppr pred) - --- | Returns the ThLevel of evidence for the solved constraint (if it has evidence) --- See Note [Well-staged instance evidence] -checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel) -checkWellStagedInstanceWhat what - | TopLevInstance { iw_dfun_id = dfun_id } <- what - = return $ Just (TcM.topIdLvl dfun_id) - | BuiltinTypeableInstance tc <- what - = do - cur_mod <- extractModule <$> getGblEnv - return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc) - then outerLevel - else impLevel) - | otherwise = return Nothing - -{- -Note [Well-staged instance evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Evidence for instances must obey the same level restrictions as normal bindings. -In particular, it is forbidden to use an instance in a top-level splice in the -module which the instance is defined. This is because the evidence is bound at -the top-level and top-level definitions are forbidden from being using in top-level splices in -the same module. - -For example, suppose you have a function.. foo :: Show a => Code Q a -> Code Q () -then the following program is disallowed, - -``` -data T a = T a deriving (Show) - -main :: IO () -main = - let x = $$(foo [|| T () ||]) - in return () -``` - -because the `foo` function (used in a top-level splice) requires `Show T` evidence, -which is defined at the top-level and therefore fails with an error that we have violated -the stage restriction. - -``` -Main.hs:12:14: error: - • GHC stage restriction: - instance for ‘Show - (T ())’ is used in a top-level splice, quasi-quote, or annotation, - and must be imported, not defined locally - • In the expression: foo [|| T () ||] - In the Template Haskell splice $$(foo [|| T () ||]) - In the expression: $$(foo [|| T () ||]) - | -12 | let x = $$(foo [|| T () ||]) - | -``` - -Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on -`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT` -is well staged. It's easy to know the stage of `$tcT`: for imported TyCons it -will be `impLevel`, and for local TyCons it will be `toplevel`. - -Therefore the `InstanceWhat` type had to be extended with -a special case for `Typeable`, which recorded the TyCon the evidence was for and -could them be used to check that we were not attempting to evidence in a stage incorrect -manner. - --} - -pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 - -isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) -isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) - -isFilledMetaTyVar :: TcTyVar -> TcS Bool -isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) - -zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet -zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs) - -zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] -zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs) - -zonkCo :: Coercion -> TcS Coercion -zonkCo = wrapTcS . TcM.zonkCo - -zonkTcType :: TcType -> TcS TcType -zonkTcType ty = wrapTcS (TcM.zonkTcType ty) - -zonkTcTypes :: [TcType] -> TcS [TcType] -zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys) - -zonkTcTyVar :: TcTyVar -> TcS TcType -zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) - -zonkSimples :: Cts -> TcS Cts -zonkSimples cts = wrapTcS (TcM.zonkSimples cts) - -zonkWC :: WantedConstraints -> TcS WantedConstraints -zonkWC wc = wrapTcS (TcM.zonkWC wc) - -zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar -zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv) - ----------------------------- -pprKicked :: Int -> SDoc -pprKicked 0 = empty -pprKicked n = parens (int n <+> text "kicked out") - -{- ********************************************************************* -* * -* The Unification Level Flag * -* * -********************************************************************* -} - -{- Note [The Unification Level Flag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a deep tree of implication constraints - forall[1] a. -- Outer-implic - C alpha[1] -- Simple - forall[2] c. ....(C alpha[1]).... -- Implic-1 - forall[2] b. ....(alpha[1] ~ Int).... -- Implic-2 - -The (C alpha) is insoluble until we know alpha. We solve alpha -by unifying alpha:=Int somewhere deep inside Implic-2. But then we -must try to solve the Outer-implic all over again. This time we can -solve (C alpha) both in Outer-implic, and nested inside Implic-1. - -When should we iterate solving a level-n implication? -Answer: if any unification of a tyvar at level n takes place - in the ic_implics of that implication. - -* What if a unification takes place at level n-1? Then don't iterate - level n, because we'll iterate level n-1, and that will in turn iterate - level n. - -* What if a unification takes place at level n, in the ic_simples of - level n? No need to track this, because the kick-out mechanism deals - with it. (We can't drop kick-out in favour of iteration, because kick-out - works for skolem-equalities, not just unifications.) - -So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps -track of - - Whether any unifications at all have taken place (Nothing => no unifications) - - If so, what is the outermost level that has seen a unification (Just lvl) - -The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver. - -It helpful not to iterate unless there is a chance of progress. #8474 is -an example: - - * There's a deeply-nested chain of implication constraints. - ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - - * From the innermost one we get a [W] alpha[1] ~ Int, - so we can unify. - - * It's better not to iterate the inner implications, but go all the - way out to level 1 before iterating -- because iterating level 1 - will iterate the inner levels anyway. - -(In the olden days when we "floated" thse Derived constraints, this was -much, much more important -- we got exponential behaviour, as each iteration -produced the same Derived constraint.) --} - - -resetUnificationFlag :: TcS Bool --- We are at ambient level i --- If the unification flag = Just i, reset it to Nothing and return True --- Otherwise leave it unchanged and return False -resetUnificationFlag - = TcS $ \env -> - do { let ref = tcs_unif_lvl env - ; ambient_lvl <- TcM.getTcLevel - ; mb_lvl <- TcM.readTcRef ref - ; TcM.traceTc "resetUnificationFlag" $ - vcat [ text "ambient:" <+> ppr ambient_lvl - , text "unif_lvl:" <+> ppr mb_lvl ] - ; case mb_lvl of - Nothing -> return False - Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl - -> return False - | otherwise - -> do { TcM.writeTcRef ref Nothing - ; return True } } - -setUnificationFlag :: TcLevel -> TcS () --- (setUnificationFlag i) sets the unification level to (Just i) --- unless it already is (Just j) where j <= i -setUnificationFlag lvl - = TcS $ \env -> - do { let ref = tcs_unif_lvl env - ; mb_lvl <- TcM.readTcRef ref - ; case mb_lvl of - Just unif_lvl | lvl `deeperThanOrSame` unif_lvl - -> return () - _ -> TcM.writeTcRef ref (Just lvl) } - - -{- ********************************************************************* -* * -* Instantiation etc. -* * -********************************************************************* -} - --- Instantiations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) -instDFunType dfun_id inst_tys - = wrapTcS $ TcM.instDFunType dfun_id inst_tys - -newFlexiTcSTy :: Kind -> TcS TcType -newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) - -cloneMetaTyVar :: TcTyVar -> TcS TcTyVar -cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) - -instFlexiX :: Subst -> [TKVar] -> TcS Subst -instFlexiX subst tvs - = wrapTcS (foldlM instFlexiHelper subst tvs) - -instFlexiHelper :: Subst -> TKVar -> TcM Subst --- Makes fresh tyvar, extends the substitution, and the in-scope set -instFlexiHelper subst tv - = do { uniq <- TcM.newUnique - ; details <- TcM.newMetaDetails TauTv - ; let name = setNameUnique (tyVarName tv) uniq - kind = substTyUnchecked subst (tyVarKind tv) - tv' = mkTcTyVar name kind details - subst' = extendTvSubstWithClone subst tv tv' - ; TcM.traceTc "instFlexi" (ppr tv') - ; return (extendTvSubst subst' tv (mkTyVarTy tv')) } - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcS TcM.ClsInstResult -matchGlobalInst dflags short_cut cls tys - = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) - -tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) -tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs - --- Creating and setting evidence variables and CtFlavors --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data MaybeNew = Fresh CtEvidence | Cached EvExpr - -isFresh :: MaybeNew -> Bool -isFresh (Fresh {}) = True -isFresh (Cached {}) = False - -freshGoals :: [MaybeNew] -> [CtEvidence] -freshGoals mns = [ ctev | Fresh ctev <- mns ] - -getEvExpr :: MaybeNew -> EvExpr -getEvExpr (Fresh ctev) = ctEvExpr ctev -getEvExpr (Cached evt) = evt - -setEvBind :: EvBind -> TcS () -setEvBind ev_bind - = do { evb <- getTcEvBindsVar - ; wrapTcS $ TcM.addTcEvBind evb ev_bind } - --- | Mark variables as used filling a coercion hole -useVars :: CoVarSet -> TcS () -useVars co_vars - = do { ev_binds_var <- getTcEvBindsVar - ; let ref = ebv_tcvs ev_binds_var - ; wrapTcS $ - do { tcvs <- TcM.readTcRef ref - ; let tcvs' = tcvs `unionVarSet` co_vars - ; TcM.writeTcRef ref tcvs' } } - --- | Equalities only -setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS () -setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) - --- | Good for both equalities and non-equalities -setWantedEvTerm :: TcEvDest -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) tm - | Just co <- evTermCoercion_maybe tm - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } - | otherwise - = -- See Note [Yukky eq_sel for a HoleDest] - do { let co_var = coHoleCoVar hole - ; setEvBind (mkWantedEvBind co_var tm) - ; fillCoercionHole hole (mkCoVarCo co_var) } - -setWantedEvTerm (EvVarDest ev_id) tm - = setEvBind (mkWantedEvBind ev_id tm) - -{- Note [Yukky eq_sel for a HoleDest] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How can it be that a Wanted with HoleDest gets evidence that isn't -just a coercion? i.e. evTermCoercion_maybe returns Nothing. - -Consider [G] forall a. blah => a ~ T - [W] S ~# T - -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T) -in the quantified constraints, and wraps the (boxed) evidence it -gets back in an eq_sel to extract the unboxed (S ~# T). We can't put -that term into a coercion, so we add a value binding - h = eq_sel (...) -and the coercion variable h to fill the coercion hole. -We even re-use the CoHole's Id for this binding! - -Yuk! --} - -fillCoercionHole :: CoercionHole -> Coercion -> TcS () -fillCoercionHole hole co - = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole } - -setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () -setEvBindIfWanted ev tm - = case ev of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm - _ -> return () - -newTcEvBinds :: TcS EvBindsVar -newTcEvBinds = wrapTcS TcM.newTcEvBinds - -newNoTcEvBinds :: TcS EvBindsVar -newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds - -newEvVar :: TcPredType -> TcS EvVar -newEvVar pred = wrapTcS (TcM.newEvVar pred) - -newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence --- Make a new variable of the given PredType, --- immediately bind it to the given term --- and return its CtEvidence --- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint -newGivenEvVar loc (pred, rhs) - = do { new_ev <- newBoundEvVarId pred rhs - ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } - --- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the --- given term -newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar -newBoundEvVarId pred rhs - = do { new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) - ; return new_ev } - -newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] -newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts - -emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion --- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc rewriters role ty1 ty2 - = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2 - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) - ; return co } - --- | Create a new Wanted constraint holding a coercion hole --- for an equality between the two types at the given 'Role'. -newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq loc rewriters role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole pty - ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) - ; return ( CtWanted { ctev_pred = pty - , ctev_dest = HoleDest hole - , ctev_loc = loc - , ctev_rewriters = rewriters } - , mkHoleCo hole ) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Create a new Wanted constraint holding an evidence variable. --- --- Don't use this for equality constraints: use 'newWantedEq' instead. -newWantedEvVarNC :: CtLoc -> RewriterSet - -> TcPredType -> TcS CtEvidence --- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC loc rewriters pty - = do { new_ev <- newEvVar pty - ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ - pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty - , ctev_dest = EvVarDest new_ev - , ctev_loc = loc - , ctev_rewriters = rewriters })} - --- | Like 'newWantedEvVarNC', except it might look up in the inert set --- to see if an inert already exists, and uses that instead of creating --- a new Wanted constraint. --- --- Don't use this for equality constraints: this function is only for --- constraints with 'EvVarDest'. -newWantedEvVar :: CtLoc -> RewriterSet - -> TcPredType -> TcS MaybeNew --- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar loc rewriters pty - = assertPpr (not (isEqPrimPred pty)) - (vcat [ text "newWantedEvVar: HoleDestPred" - , text "pty:" <+> ppr pty ]) $ - do { mb_ct <- lookupInInerts loc pty - ; case mb_ct of - Just ctev - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC loc rewriters pty - ; return (Fresh ctev) } } - --- | Create a new Wanted constraint, potentially looking up --- non-equality constraints in the cache instead of creating --- a new one from scratch. --- --- Deals with both equality and non-equality constraints. -newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew -newWanted loc rewriters pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2 - | otherwise - = newWantedEvVar loc rewriters pty - --- | Create a new Wanted constraint. --- --- Deals with both equality and non-equality constraints. --- --- Does not attempt to re-use non-equality constraints that already --- exist in the inert set. -newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence -newWantedNC loc rewriters pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc rewriters role ty1 ty2 - | otherwise - = newWantedEvVarNC loc rewriters pty - --- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- --- | Checks if the depth of the given location is too much. Fails if --- it's too big, with an appropriate error message. -checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced - -> TcS () -checkReductionDepth loc ty - = do { dflags <- getDynFlags - ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ - wrapErrTcS $ solverDepthError loc ty } - -matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN) -matchFam tycon args = wrapTcS $ matchFamTcM tycon args - -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFamTcM tycon args - = do { fam_envs <- FamInst.tcGetFamInstEnvs - ; let match_fam_result - = reduceTyFamApp_maybe fam_envs Nominal tycon args - ; TcM.traceTc "matchFamTcM" $ - vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) - , ppr_res match_fam_result ] - ; return match_fam_result } - where - ppr_res Nothing = text "Match failed" - ppr_res (Just (Reduction co ty)) - = hang (text "Match succeeded:") - 2 (vcat [ text "Rewrites to:" <+> ppr ty - , text "Coercion:" <+> ppr co ]) - -solverDepthError :: CtLoc -> TcType -> TcM a -solverDepthError loc ty - = TcM.setCtLocM loc $ - do { ty <- TcM.zonkTcType ty - ; env0 <- TcM.tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; TcM.failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - note = vcat - [ text "Use -freduction-depth=0 to disable this check" - , text "(any upper bound you could choose might fail unpredictably with" - , text " minor updates to GHC, so disabling the check is recommended if" - , text " you're sure that type checking should terminate)" ] - - -{- -************************************************************************ -* * - Breaking type variable cycles -* * -************************************************************************ --} - --- | Conditionally replace all type family applications in the RHS with fresh --- variables, emitting givens that relate the type family application to the --- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. --- This only works under conditions as described in the Note; otherwise, returns --- Nothing. -breakTyEqCycle_maybe :: CtEvidence - -> CheckTyEqResult -- result of checkTypeEq - -> CanEqLHS - -> TcType -- RHS - -> TcS (Maybe ReductionN) - -- new RHS that doesn't have any type families -breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _ - -- see Detail (7) of Note - = return Nothing - -breakTyEqCycle_maybe ev cte_result lhs rhs - | NomEq <- eq_rel - - , cte_result `cterHasOnlyProblem` cteSolubleOccurs - -- only do this if the only problem is a soluble occurs-check - -- See Detail (8) of the Note. - - = do { should_break <- final_check - ; mapM go should_break } - where - flavour = ctEvFlavour ev - eq_rel = ctEvEqRel ev - - final_check = case flavour of - Given -> return $ Just rhs - Wanted -- Wanteds work only with a touchable tyvar on the left - -- See "Wanted" section of the Note. - | TyVarLHS lhs_tv <- lhs -> - do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs - ; return $ case result of - Untouchable -> Nothing - _ -> Just rhs } - | otherwise -> return Nothing - - -- This could be considerably more efficient. See Detail (5) of Note. - go :: TcType -> TcS ReductionN - go ty | Just ty' <- rewriterView ty = go ty' - go (Rep.TyConApp tc tys) - | isTypeFamilyTyCon tc -- worried about whether this type family is not actually - -- causing trouble? See Detail (5) of Note. - = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys - fun_app = mkTyConApp tc fun_args - fun_app_kind = typeKind fun_app - ; fun_redn <- emit_work fun_app_kind fun_app - ; arg_redns <- unzipRedns <$> mapM go extra_args - ; return $ mkAppRedns fun_redn arg_redns } - -- Worried that this substitution will change kinds? - -- See Detail (3) of Note - - | otherwise - = do { arg_redns <- unzipRedns <$> mapM go tys - ; return $ mkTyConAppRedn Nominal tc arg_redns } - - go (Rep.AppTy ty1 ty2) - = mkAppRedn <$> go ty1 <*> go ty2 - go (Rep.FunTy vis w arg res) - = mkFunRedn Nominal vis <$> go w <*> go arg <*> go res - go (Rep.CastTy ty cast_co) - = mkCastRedn1 Nominal ty cast_co <$> go ty - go ty@(Rep.TyVarTy {}) = skip ty - go ty@(Rep.LitTy {}) = skip ty - go ty@(Rep.ForAllTy {}) = skip ty -- See Detail (1) of Note - go ty@(Rep.CoercionTy {}) = skip ty -- See Detail (2) of Note - - skip ty = return $ mkReflRedn Nominal ty - - emit_work :: TcKind -- of the function application - -> TcType -- original function application - -> TcS ReductionN -- rewritten type (the fresh tyvar) - emit_work fun_app_kind fun_app = case flavour of - Given -> - do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind) - ; let new_ty = mkTyVarTy new_tv - given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind - fun_app new_ty - given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note - ; new_given <- newGivenEvVar new_loc (given_pred, given_term) - ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given) - ; emitWorkNC [new_given] - ; updInertTcS $ \is -> - is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app - (inert_cycle_breakers is) } - ; return $ mkReflRedn Nominal new_ty } - -- Why reflexive? See Detail (4) of the Note - - Wanted -> - do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind) - ; let new_ty = mkTyVarTy new_tv - ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app - ; return $ mkReduction (mkSymCo co) new_ty } - - -- See Detail (7) of the Note - new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin - --- does not fit scenario from Note -breakTyEqCycle_maybe _ _ _ _ = return Nothing - --- | Fill in CycleBreakerTvs with the variables they stand for. --- See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. -restoreTyVarCycles :: InertSet -> TcM () -restoreTyVarCycles is - = forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar -{-# SPECIALISE forAllCycleBreakerBindings_ :: - CycleBreakerVarStack -> (TcTyVar -> TcType -> TcM ()) -> TcM () #-} - --- Unwrap a type synonym only when either: --- The type synonym is forgetful, or --- the type synonym mentions a type family in its expansion --- See Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite. -rewriterView :: TcType -> Maybe TcType -rewriterView ty@(Rep.TyConApp tc _) - | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc)) - = coreView ty -rewriterView _other = Nothing + emitFunDepWanteds, + + selectNextWorkItem, + getWorkList, + updWorkListTcS, + pushLevelNoWorkList, + + runTcPluginTcS, recordUsedGREs, + matchGlobalInst, TcM.ClsInstResult(..), + + QCInst(..), + + -- The pipeline + StopOrContinue(..), continueWith, stopWith, + startAgainWith, SolverStage(Stage, runSolverStage), simpleStage, + stopWithStage, + + -- Tracing etc + panicTcS, traceTcS, tryEarlyAbortTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, + wrapErrTcS, wrapWarnTcS, + resetUnificationFlag, setUnificationFlag, + + -- Evidence creation and transformation + MaybeNew(..), freshGoals, isFresh, getEvExpr, + + newTcEvBinds, newNoTcEvBinds, + newWantedEq, emitNewWantedEq, + newWanted, + newWantedNC, newWantedEvVarNC, + newBoundEvVarId, + unifyTyVar, reportUnifications, touchabilityAndShapeTest, + setEvBind, setWantedEq, + setWantedEvTerm, setEvBindIfWanted, + newEvVar, newGivenEvVar, emitNewGivens, + checkReductionDepth, + getSolvedDicts, setSolvedDicts, + + getInstEnvs, getFamInstEnvs, -- Getting the environments + getTopEnv, getGblEnv, getLclEnv, setSrcSpan, + getTcEvBindsVar, getTcLevel, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + tcLookupClass, tcLookupId, tcLookupTyCon, + + + -- Inerts + updInertSet, updInertCans, + getHasGivenEqs, setInertCans, + getInertEqs, getInertCans, getInertGivens, + getInertInsols, getInnermostGivenEqLevel, + getInertSet, setInertSet, + getUnsolvedInerts, + removeInertCts, getPendingGivenScs, + insertFunEq, addInertForAll, + emitWorkNC, emitWork, + lookupInertDict, + + -- The Model + kickOutAfterUnification, kickOutRewritable, + + -- Inert Safe Haskell safe-overlap failures + addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, + getSafeOverlapFailures, + + -- Inert solved dictionaries + updSolvedDicts, lookupSolvedDict, + + -- Irreds + foldIrreds, + + -- The family application cache + lookupFamAppInert, lookupFamAppCache, extendFamAppCache, + pprKicked, + + -- Instantiation + instDFunType, + + -- Unification + wrapUnifierTcS, unifyFunDeps, uPairsTcM, + + -- MetaTyVars + newFlexiTcSTy, instFlexiX, + cloneMetaTyVar, + tcInstSkolTyVarsX, + + TcLevel, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, + zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, + zonkTyCoVarsAndFVList, + zonkSimples, zonkWC, + zonkTyCoVarKind, + + -- References + newTcRef, readTcRef, writeTcRef, updTcRef, + + -- Misc + getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, + matchFam, matchFamTcM, + checkWellStagedDFun, + pprEq, + + -- Enforcing invariants for type equalities + checkTypeEq, checkTouchableTyVarEq +) where + +import GHC.Prelude + +import GHC.Driver.Env + +import qualified GHC.Tc.Utils.Instantiate as TcM +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family as FamInst +import GHC.Core.FamInstEnv + +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) +import qualified GHC.Tc.Utils.Env as TcM + ( checkWellStaged, tcGetDefaultTys + , tcLookupClass, tcLookupId, tcLookupTyCon + , topIdLvl ) +import GHC.Tc.Zonk.Monad ( ZonkM ) +import qualified GHC.Tc.Zonk.TcType as TcM +import qualified GHC.Tc.Zonk.Type as TcM + +import GHC.Driver.DynFlags + +import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon ) +import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver.Types +import GHC.Tc.Solver.InertSet +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Unify + +import GHC.Builtin.Names ( unsatisfiableClassNameKey ) + +import GHC.Core.Type +import GHC.Core.TyCo.Rep as Rep +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom( TypeEqn ) +import GHC.Core.Predicate +import GHC.Core.Reduction +import GHC.Core.Class +import GHC.Core.TyCon + +import GHC.Types.Name +import GHC.Types.TyThing +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Supply +import GHC.Types.Unique.Set( elementOfUniqSet ) + +import GHC.Unit.Module ( HasModule, getModule, extractModule ) +import qualified GHC.Rename.Env as TcM + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Utils.Misc (HasDebugCallStack) + +import GHC.Data.Bag as Bag +import GHC.Data.Pair + +import GHC.Utils.Monad + +import GHC.Exts (oneShot) +import Control.Monad +import Data.IORef +import Data.List ( mapAccumL ) +import Data.Foldable +import qualified Data.Semigroup as S +import GHC.Types.SrcLoc +import GHC.Rename.Env + +#if defined(DEBUG) +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Data.Graph.Directed +#endif + +{- ********************************************************************* +* * + SolverStage and StopOrContinue +* * +********************************************************************* -} + +{- Note [The SolverStage monad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SolverStage monad allows us to write simple code like that in +GHC.Tc.Solver.solveEquality. At the time of writing it looked like +this (may get out of date but the idea is clear): + +solveEquality :: ... -> SolverStage Void +solveEquality ev eq_rel ty1 ty2 + = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 + ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2' + ; case mb_canon of { + Left irred_ct -> do { tryQCsIrredEqCt irred_ct + ; solveIrred irred_ct } ; + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_ct + ; tryQCsEqCt eq_ct + ; simpleStage (updInertEqs eq_ct) + ; stopWithStage (eqCtEvidence eq_ct) ".." }}} + +Each sub-stage can elect to + (a) ContinueWith: continue to the next stasge + (b) StartAgain: start again at the beginning of the pipeline + (c) Stop: stop altogether; constraint is solved + +These three possiblities are described by the `StopOrContinue` data type. +The `SolverStage` monad does the plumbing. + +Notes: + +(SM1) Each individual stage pretty quickly drops down into + TcS (StopOrContinue a) + because the monadic plumbing of `SolverStage` is relatively ineffienct, + with that three-way split. + +(SM2) We use `SolverStage Void` to express the idea that ContinueWith is + impossible; we don't need to pattern match on it as a possible outcome:A + see GHC.Tc.Solver.Solve.solveOne. To that end, ContinueWith is strict. +-} + +data StopOrContinue a + = StartAgain Ct -- Constraint is not solved, but some unifications + -- happened, so go back to the beginning of the pipeline + + | ContinueWith !a -- The constraint was not solved, although it may have + -- been rewritten. It is strict so that + -- ContinueWith Void can't happen; see (SM2) in + -- Note [The SolverStage monad] + + | Stop CtEvidence -- The (rewritten) constraint was solved + SDoc -- Tells how it was solved + -- Any new sub-goals have been put on the work list + deriving (Functor) + +instance Outputable a => Outputable (StopOrContinue a) where + ppr (Stop ev s) = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev) + ppr (ContinueWith w) = text "ContinueWith" <+> ppr w + ppr (StartAgain w) = text "StartAgain" <+> ppr w + +newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) } + deriving( Functor ) + +instance Applicative SolverStage where + pure x = Stage (return (ContinueWith x)) + (<*>) = ap + +instance Monad SolverStage where + return = pure + (Stage m) >>= k = Stage $ + do { soc <- m + ; case soc of + StartAgain x -> return (StartAgain x) + Stop ev d -> return (Stop ev d) + ContinueWith x -> runSolverStage (k x) } + +simpleStage :: TcS a -> SolverStage a +-- Always does a ContinueWith; no Stop or StartAgain +simpleStage thing = Stage (do { res <- thing; continueWith res }) + +startAgainWith :: Ct -> TcS (StopOrContinue a) +startAgainWith ct = return (StartAgain ct) + +continueWith :: a -> TcS (StopOrContinue a) +continueWith ct = return (ContinueWith ct) + +stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) +stopWith ev s = return (Stop ev (text s)) + +stopWithStage :: CtEvidence -> String -> SolverStage a +stopWithStage ev s = Stage (stopWith ev s) + + +{- ********************************************************************* +* * + Inert instances: inert_insts +* * +********************************************************************* -} + +addInertForAll :: QCInst -> TcS () +-- Add a local Given instance, typically arising from a type signature +addInertForAll new_qci + = do { ics <- getInertCans + ; ics1 <- add_qci ics + + -- Update given equalities. C.f updateGivenEqs + ; tclvl <- getTcLevel + ; let pred = qci_pred new_qci + not_equality = isClassPred pred && not (isEqPred pred) + -- True <=> definitely not an equality + -- A qci_pred like (f a) might be an equality + + ics2 | not_equality = ics1 + | otherwise = ics1 { inert_given_eq_lvl = tclvl + , inert_given_eqs = True } + + ; setInertCans ics2 } + where + add_qci :: InertCans -> TcS InertCans + -- See Note [Do not add duplicate quantified instances] + add_qci ics@(IC { inert_insts = qcis }) + | any same_qci qcis + = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) + ; return ics } + + | otherwise + = do { traceTcS "adding new inert quantified instance" (ppr new_qci) + ; return (ics { inert_insts = new_qci : qcis }) } + + same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) + (ctEvPred (qci_ev new_qci)) + +{- Note [Do not add duplicate quantified instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an optimisation, we avoid adding duplicate quantified instances to the +inert set; we use a simple duplicate check using tcEqType for simplicity, +even though it doesn't account for superficial differences, e.g. it will count +the following two constraints as different (#22223): + + - forall a b. C a b + - forall b a. C a b + +The main logic that allows us to pick local instances, even in the presence of +duplicates, is explained in Note [Use only the best matching quantified constraint] +in GHC.Tc.Solver.Dict. +-} + +{- ********************************************************************* +* * + Kicking out +* * +************************************************************************ +-} + + +----------------------------------------- +kickOutRewritable :: KickOutSpec -> CtFlavourRole -> TcS () +kickOutRewritable ko_spec new_fr + = do { ics <- getInertCans + ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics + n_kicked = lengthBag kicked_out + ; setInertCans ics' + + ; unless (isEmptyBag kicked_out) $ + do { emitWork kicked_out + + -- The famapp-cache contains Given evidence from the inert set. + -- If we're kicking out Givens, we need to remove this evidence + -- from the cache, too. + ; let kicked_given_ev_vars = foldr add_one emptyVarSet kicked_out + add_one :: Ct -> VarSet -> VarSet + add_one ct vs | CtGiven { ctev_evar = ev_var } <- ctEvidence ct + = vs `extendVarSet` ev_var + | otherwise = vs + + ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && + -- if this isn't true, no use looking through the constraints + not (isEmptyVarSet kicked_given_ev_vars)) $ + do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" + (ppr kicked_given_ev_vars) + ; dropFromFamAppCache kicked_given_ev_vars } + + ; csTraceTcS $ + hang (text "Kick out") + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } } + +kickOutAfterUnification :: [TcTyVar] -> TcS () +kickOutAfterUnification tvs + | null tvs + = return () + | otherwise + = do { let tv_set = mkVarSet tvs + + ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq) + -- Given because the tv := xi is given; NomEq because + -- only nominal equalities are solved by unification + + -- Set the unification flag if we have done outer unifications + -- that might affect an earlier implication constraint + ; let min_tv_lvl = foldr1 minTcLevel (map tcTyVarLevel tvs) + ; ambient_lvl <- getTcLevel + ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $ + setUnificationFlag min_tv_lvl + + ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked) + ; return n_kicked } + +kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () +-- See Wrinkle (EIK2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality +-- It's possible that this could just go ahead and unify, but could there be occurs-check +-- problems? Seems simpler just to kick out. +kickOutAfterFillingCoercionHole hole + = do { ics <- getInertCans + ; let (kicked_out, ics') = kick_out ics + n_kicked = lengthBag kicked_out + + ; unless (n_kicked == 0) $ + do { updWorkListTcS (extendWorkListCts (fmap CIrredCan kicked_out)) + ; csTraceTcS $ + hang (text "Kick out, hole =" <+> ppr hole) + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } + + ; setInertCans ics' } + where + kick_out :: InertCans -> (Bag IrredCt, InertCans) + kick_out ics@(IC { inert_irreds = irreds }) + = -- We only care about irreds here, because any constraint blocked + -- by a coercion hole is an irred. See wrinkle (EIK2a) in + -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical + (irreds_to_kick, ics { inert_irreds = irreds_to_keep }) + where + (irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds + + kick_ct :: IrredCt -> Bool + -- True: kick out; False: keep. + kick_ct ct + | IrredCt { ir_ev = ev, ir_reason = reason } <- ct + , CtWanted { ctev_rewriters = RewriterSet rewriters } <- ev + , NonCanonicalReason ctyeq <- reason + , ctyeq `cterHasProblem` cteCoercionHole + , hole `elementOfUniqSet` rewriters + = True + | otherwise + = False + +-------------- +addInertSafehask :: InertCans -> DictCt -> InertCans +addInertSafehask ics item + = ics { inert_safehask = addDict item (inert_dicts ics) } + +insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> TcS () +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +insertSafeOverlapFailureTcS what item + | safeOverlap what = return () + | otherwise = updInertCans (\ics -> addInertSafehask ics item) + +getSafeOverlapFailures :: TcS (Bag DictCt) +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +getSafeOverlapFailures + = do { IC { inert_safehask = safehask } <- getInertCans + ; return $ foldDicts consBag safehask emptyBag } + +-------------- +updSolvedDicts :: InstanceWhat -> DictCt -> TcS () +-- Conditionally add a new item in the solved set of the monad +-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet +updSolvedDicts what dict_ct@(DictCt { di_ev = ev }) + | isWanted ev + , instanceReturnsDictCon what + = do { traceTcS "updSolvedDicts:" $ ppr dict_ct + ; updInertSet $ \ ics -> + ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } } + | otherwise + = return () + +getSolvedDicts :: TcS (DictMap DictCt) +getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) } + +setSolvedDicts :: DictMap DictCt -> TcS () +setSolvedDicts solved_dicts + = updInertSet $ \ ics -> + ics { inert_solved_dicts = solved_dicts } + +{- ********************************************************************* +* * + Other inert-set operations +* * +********************************************************************* -} + +updInertSet :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertSet upd_fn + = do { is_var <- getInertSetRef + ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var + ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } + +getInertCans :: TcS InertCans +getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) } + +setInertCans :: InertCans -> TcS () +setInertCans ics = updInertSet $ \ inerts -> inerts { inert_cans = ics } + +updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a +-- Modify the inert set with the supplied function +updRetInertCans upd_fn + = do { is_var <- getInertSetRef + ; wrapTcS (do { inerts <- TcM.readTcRef is_var + ; let (res, cans') = upd_fn (inert_cans inerts) + ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) + ; return res }) } + +updInertCans :: (InertCans -> InertCans) -> TcS () +-- Modify the inert set with the supplied function +updInertCans upd_fn + = updInertSet $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } + +updInertSafehask :: (DictMap DictCt -> DictMap DictCt) -> TcS () +-- Modify the inert set with the supplied function +updInertSafehask upd_fn + = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } + +getInertEqs :: TcS InertEqs +getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } + +getInnermostGivenEqLevel :: TcS TcLevel +getInnermostGivenEqLevel = do { inert <- getInertCans + ; return (inert_given_eq_lvl inert) } + +-- | Retrieves all insoluble constraints from the inert set, +-- specifically including Given constraints. +-- +-- This consists of: +-- +-- - insoluble equalities, such as @Int ~# Bool@; +-- - constraints that are top-level custom type errors, of the form +-- @TypeError msg@, but not constraints such as @Eq (TypeError msg)@ +-- in which the type error is nested; +-- - unsatisfiable constraints, of the form @Unsatisfiable msg@. +-- +-- The inclusion of Givens is important for pattern match warnings, as we +-- want to consider a pattern match that introduces insoluble Givens to be +-- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver). +getInertInsols :: TcS Cts +getInertInsols + = do { inert <- getInertCans + ; let insols = filterBag insolubleIrredCt (inert_irreds inert) + unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey + ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols } + +getInertGivens :: TcS [Ct] +-- Returns the Given constraints in the inert set +getInertGivens + = do { inerts <- getInertCans + ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts) + $ foldDicts ((:) . CDictCan) (inert_dicts inerts) + $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts) + $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts) + $ [] + ; return (filter isGivenCt all_cts) } + +getPendingGivenScs :: TcS [Ct] +-- Find all inert Given dictionaries, or quantified constraints, such that +-- 1. cc_pend_sc flag has fuel strictly > 0 +-- 2. belongs to the current level +-- For each such dictionary: +-- * Return it (with unmodified cc_pend_sc) in sc_pending +-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand +-- to record that we have expanded superclasses for this dict +getPendingGivenScs = do { lvl <- getTcLevel + ; updRetInertCans (get_sc_pending lvl) } + +get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) +get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) + = assertPpr (all isGivenCt sc_pending) (ppr sc_pending) + -- When getPendingScDics is called, + -- there are never any Wanteds in the inert set + (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) + where + sc_pending = sc_pend_insts ++ map CDictCan sc_pend_dicts + + sc_pend_dicts :: [DictCt] + sc_pend_dicts = foldDicts get_pending dicts [] + dicts' = foldr exhaustAndAdd dicts sc_pend_dicts + + (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts + + exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt + exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts + -- Exhaust the fuel for this constraint before adding it as + -- we don't want to expand these constraints again + + get_pending :: DictCt -> [DictCt] -> [DictCt] -- Get dicts with cc_pend_sc > 0 + get_pending dict dicts + | isPendingScDictCt dict + , belongs_to_this_level (dictCtEvidence dict) + = dict : dicts + | otherwise + = dicts + + get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) + get_pending_inst cts qci@(QCI { qci_ev = ev }) + | Just qci' <- pendingScInst_maybe qci + , belongs_to_this_level ev + = (CQuantCan qci : cts, qci') + -- qci' have their fuel exhausted + -- we don't want to expand these constraints again + -- qci is expanded + | otherwise + = (cts, qci) + + belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl + -- We only want Givens from this level; see (3a) in + -- Note [The superclass story] in GHC.Tc.Solver.Dict + +getUnsolvedInerts :: TcS ( Bag Implication + , Cts ) -- All simple constraints +-- Return all the unsolved [Wanted] constraints +-- +-- Post-condition: the returned simple constraints are all fully zonked +-- (because they come from the inert set) +-- the unsolved implics may not be +getUnsolvedInerts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds + , inert_dicts = idicts + } <- getInertCans + + ; let unsolved_tv_eqs = foldTyEqs (add_if_unsolved CEqCan) tv_eqs emptyCts + unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan) fun_eqs emptyCts + unsolved_irreds = foldr (add_if_unsolved CIrredCan) emptyCts irreds + unsolved_dicts = foldDicts (add_if_unsolved CDictCan) idicts emptyCts + + ; implics <- getWorkListImplics + + ; traceTcS "getUnsolvedInerts" $ + vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs + , text "fun eqs =" <+> ppr unsolved_fun_eqs + , text "dicts =" <+> ppr unsolved_dicts + , text "irreds =" <+> ppr unsolved_irreds + , text "implics =" <+> ppr implics ] + + ; return ( implics, unsolved_tv_eqs `unionBags` + unsolved_fun_eqs `unionBags` + unsolved_irreds `unionBags` + unsolved_dicts ) } + where + add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts + add_if_unsolved mk_ct thing cts + | isWantedCt ct = ct `consCts` cts + | otherwise = cts + where + ct = mk_ct thing + +getHasGivenEqs :: TcLevel -- TcLevel of this implication + -> TcS ( HasGivenEqs -- are there Given equalities? + , InertIrreds ) -- Insoluble equalities arising from givens +-- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet +getHasGivenEqs tclvl + = do { inerts@(IC { inert_irreds = irreds + , inert_given_eqs = given_eqs + , inert_given_eq_lvl = ge_lvl }) + <- getInertCans + ; let given_insols = filterBag insoluble_given_equality irreds + -- Specifically includes ones that originated in some + -- outer context but were refined to an insoluble by + -- a local equality; so no level-check needed + + -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and + -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + has_ge | ge_lvl == tclvl = MaybeGivenEqs + | given_eqs = LocalGivenEqs + | otherwise = NoGivenEqs + + ; traceTcS "getHasGivenEqs" $ + vcat [ text "given_eqs:" <+> ppr given_eqs + , text "ge_lvl:" <+> ppr ge_lvl + , text "ambient level:" <+> ppr tclvl + , text "Inerts:" <+> ppr inerts + , text "Insols:" <+> ppr given_insols] + ; return (has_ge, given_insols) } + where + insoluble_given_equality :: IrredCt -> Bool + -- Check for unreachability; specifically do not include UserError/Unsatisfiable + insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason && isGiven ev + +removeInertCts :: [Ct] -> InertCans -> InertCans +-- ^ Remove inert constraints from the 'InertCans', for use when a +-- typechecker plugin wishes to discard a given. +removeInertCts cts icans = foldl' removeInertCt icans cts + +removeInertCt :: InertCans -> Ct -> InertCans +removeInertCt is ct + = case ct of + CDictCan dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) } + CEqCan eq_ct -> delEq eq_ct is + CIrredCan ir_ct -> delIrred ir_ct is + CQuantCan {} -> panic "removeInertCt: CQuantCan" + CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + +-- | Looks up a family application in the inerts. +lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? + -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) +lookupFamAppInert rewrite_pred fam_tc tys + = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet + ; return (lookup_inerts inert_funeqs) } + where + lookup_inerts inert_funeqs + | Just ecl <- findFunEq inert_funeqs fam_tc tys + , Just (EqCt { eq_ev = ctev, eq_rhs = rhs }) + <- find (rewrite_pred . eqCtFlavourRole) ecl + = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev) + | otherwise = Nothing + +lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) +-- Is this exact predicate type cached in the solved or canonicals of the InertSet? +lookupInInerts loc pty + | ClassPred cls tys <- classifyPredType pty + = do { inerts <- getInertSet + ; let mb_solved = lookupSolvedDict inerts loc cls tys + mb_inert = fmap dictCtEvidence (lookupInertDict (inert_cans inerts) loc cls tys) + ; return $ do -- Maybe monad + found_ev <- mb_solved `mplus` mb_inert + + -- We're about to "solve" the wanted we're looking up, so we + -- must make sure doing so wouldn't run afoul of + -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. + -- Forgetting this led to #20666. + guard $ not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc) + + return found_ev } + | otherwise -- NB: No caching for equalities, IPs, holes, or errors + = return Nothing + +-- | Look up a dictionary inert. +lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe DictCt +lookupInertDict (IC { inert_dicts = dicts }) loc cls tys + = findDict dicts loc cls tys + +-- | Look up a solved inert. +lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence +-- Returns just if exactly this predicate type exists in the solved. +lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys + = fmap dictCtEvidence (findDict solved loc cls tys) + +--------------------------- +lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction) +lookupFamAppCache fam_tc tys + = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet + ; case findFunEq famapp_cache fam_tc tys of + result@(Just redn) -> + do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys) + , ppr redn ]) + ; return result } + Nothing -> return Nothing } + +extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS () +-- NB: co :: rhs ~ F tys, to match expectations of rewriter +extendFamAppCache tc xi_args stuff@(Reduction _ ty) + = do { dflags <- getDynFlags + ; when (gopt Opt_FamAppCache dflags) $ + do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args + , ppr ty ]) + ; updInertSet $ \ is@(IS { inert_famapp_cache = fc }) -> + is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } + +-- Remove entries from the cache whose evidence mentions variables in the +-- supplied set +dropFromFamAppCache :: VarSet -> TcS () +dropFromFamAppCache varset + = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) -> + inerts { inert_famapp_cache = filterTcAppMap check famapp_cache }) + where + check :: Reduction -> Bool + check redn + = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) + +{- +************************************************************************ +* * +* The TcS solver monad * +* * +************************************************************************ + +Note [The TcS monad] +~~~~~~~~~~~~~~~~~~~~ +The TcS monad is a weak form of the main Tc monad + +All you can do is + * fail + * allocate new variables + * fill in evidence variables + +Filling in a dictionary evidence variable means to create a binding +for it, so TcS carries a mutable location where the binding can be +added. This is initialised from the innermost implication constraint. +-} + +data TcSEnv + = TcSEnv { + tcs_ev_binds :: EvBindsVar, + + tcs_unified :: IORef Int, + -- The number of unification variables we have filled + -- The important thing is whether it is non-zero + + tcs_unif_lvl :: IORef (Maybe TcLevel), + -- The Unification Level Flag + -- Outermost level at which we have unified a meta tyvar + -- Starts at Nothing, then (Just i), then (Just j) where j TcM a } + deriving (Functor) + +instance MonadFix TcS where + mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) + +-- | Smart constructor for 'TcS', as describe in Note [The one-shot state +-- monad trick] in "GHC.Utils.Monad". +mkTcS :: (TcSEnv -> TcM a) -> TcS a +mkTcS f = TcS (oneShot f) + +instance Applicative TcS where + pure x = mkTcS $ \_ -> return x + (<*>) = ap + +instance Monad TcS where + m >>= k = mkTcS $ \ebs -> do + unTcS m ebs >>= (\r -> unTcS (k r) ebs) + +instance MonadIO TcS where + liftIO act = TcS $ \_env -> liftIO act + +instance MonadFail TcS where + fail err = mkTcS $ \_ -> fail err + +instance MonadUnique TcS where + getUniqueSupplyM = wrapTcS getUniqueSupplyM + +instance HasModule TcS where + getModule = wrapTcS getModule + +instance MonadThings TcS where + lookupThing n = wrapTcS (lookupThing n) + +-- Basic functionality +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +wrapTcS :: TcM a -> TcS a +-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, +-- and TcS is supposed to have limited functionality +wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds + +liftZonkTcS :: ZonkM a -> TcS a +liftZonkTcS = wrapTcS . TcM.liftZonkM + +wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a +wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env) + +wrapErrTcS :: TcM a -> TcS a +-- The thing wrapped should just fail +-- There's no static check; it's up to the user +-- Having a variant for each error message is too painful +wrapErrTcS = wrapTcS + +wrapWarnTcS :: TcM a -> TcS a +-- The thing wrapped should just add a warning, or no-op +-- There's no static check; it's up to the user +wrapWarnTcS = wrapTcS + +panicTcS :: SDoc -> TcS a +failTcS :: TcRnMessage -> TcS a +warnTcS, addErrTcS :: TcRnMessage -> TcS () +failTcS = wrapTcS . TcM.failWith +warnTcS msg = wrapTcS (TcM.addDiagnostic msg) +addErrTcS = wrapTcS . TcM.addErr +panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc + +tryEarlyAbortTcS :: TcS () +-- Abort (fail in the monad) if the abort_on_insoluble flag is on +tryEarlyAbortTcS + = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM) + +-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'. +ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS () +ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg + +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 = wrapTcS . runTcPluginM + +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + +getGlobalRdrEnvTcS :: TcS GlobalRdrEnv +getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv + +bumpStepCountTcS :: TcS () +bumpStepCountTcS = mkTcS $ \env -> + do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } + +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 +traceFireTcS ev doc + = mkTcS $ \env -> csTraceTcM $ + do { n <- TcM.readTcRef (tcs_count env) + ; tclvl <- TcM.getTcLevel + ; return (hang (text "Step" <+> int n + <> brackets (text "l:" <> ppr tclvl <> comma <> + 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 +csTraceTcM mk_doc + = do { logger <- getLogger + ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace + || logHasDumpFlag logger Opt_D_dump_tc_trace) + ( do { msg <- mk_doc + ; TcM.dumpTcRn False + Opt_D_dump_cs_trace + "" FormatText + msg }) } +{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] + +runTcS :: TcS a -- What to run + -> TcM (a, EvBindMap) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; return (res, ev_binds) } + +-- | This variant of 'runTcS' will immediately fail upon encountering an +-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage +-- site does not need the ev_binds, so we do not return them. +runTcSEarlyAbort :: TcS a -> TcM a +runTcSEarlyAbort tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds' True True ev_binds_var tcs } + +-- | This can deal only with equality constraints. +runTcSEqualities :: TcS a -> TcM a +runTcSEqualities thing_inside + = do { ev_binds_var <- TcM.newNoTcEvBinds + ; runTcSWithEvBinds ev_binds_var thing_inside } + +-- | A variant of 'runTcS' that takes and returns an 'InertSet' for +-- later resumption of the 'TcS' session. +runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) +runTcSInerts inerts tcs = do + ev_binds_var <- TcM.newTcEvBinds + runTcSWithEvBinds' False False ev_binds_var $ do + setInertSet inerts + a <- tcs + new_inerts <- getInertSet + return (a, new_inerts) + +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds = runTcSWithEvBinds' True False + +runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards? + -- Don't if you want to reuse the InertSet. + -- See also Note [Type equality cycles] + -- in GHC.Tc.Solver.Equality + -> Bool + -> EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs + = do { unified_var <- TcM.newTcRef 0 + ; step_count <- TcM.newTcRef 0 + ; inert_var <- TcM.newTcRef emptyInert + ; wl_var <- TcM.newTcRef emptyWorkList + ; unif_lvl_var <- TcM.newTcRef Nothing + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_unif_lvl = unif_lvl_var + , tcs_count = step_count + , tcs_inerts = inert_var + , tcs_abort_on_insoluble = abort_on_insoluble + , tcs_worklist = wl_var } + + -- Run the computation + ; res <- unTcS tcs env + + ; count <- TcM.readTcRef step_count + ; when (count > 0) $ + csTraceTcM $ return (text "Constraint solver steps =" <+> int count) + + ; when restore_cycles $ + do { inert_set <- TcM.readTcRef inert_var + ; restoreTyVarCycles inert_set } + +#if defined(DEBUG) + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; checkForCyclicBinds ev_binds +#endif + + ; return res } + +---------------------------- +#if defined(DEBUG) +checkForCyclicBinds :: EvBindMap -> TcM () +checkForCyclicBinds ev_binds_map + | null cycles + = return () + | null coercion_cycles + = TcM.traceTc "Cycle in evidence binds" $ ppr cycles + | otherwise + = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles + where + ev_binds = evBindMapBinds ev_binds_map + + cycles :: [[EvBind]] + cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] + + coercion_cycles = [c | c <- cycles, any is_co_bind c] + is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b) + + edges :: [ Node EvVar EvBind ] + edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs)) + | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic even + -- if the edges are in nondeterministic order as explained in + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. +#endif + +---------------------------- +setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a +setEvBindsTcS ref (TcS thing_inside) + = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) + +nestImplicTcS :: EvBindsVar + -> TcLevel -> TcS a + -> TcS a +nestImplicTcS ref inner_tclvl (TcS thing_inside) + = TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var + , tcs_count = count + , tcs_unif_lvl = unif_lvl + , tcs_abort_on_insoluble = abort_on_insoluble + } -> + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack + (inert_cycle_breakers inerts) + , inert_cans = (inert_cans inerts) + { inert_given_eqs = False } } + -- All other InertSet fields are inherited + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = TcSEnv { tcs_count = count -- Inherited + , tcs_unif_lvl = unif_lvl -- Inherited + , tcs_ev_binds = ref + , tcs_unified = unified_var + , tcs_inerts = new_inert_var + , tcs_abort_on_insoluble = abort_on_insoluble + , tcs_worklist = new_wl_var } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env + + ; out_inert_set <- TcM.readTcRef new_inert_var + ; restoreTyVarCycles out_inert_set + +#if defined(DEBUG) + -- Perform a check that the thing_inside did not cause cycles + ; ev_binds <- TcM.getTcEvBindsMap ref + ; checkForCyclicBinds ev_binds +#endif + ; return res } + +nestTcS :: TcS a -> TcS a +-- Use the current untouchables, augmenting the current +-- evidence bindings, and solved dictionaries +-- But have no effect on the InertCans, or on the inert_famapp_cache +-- (we want to inherit the latter from processing the Givens) +nestTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> + do { inerts <- TcM.readTcRef inerts_var + ; new_inert_var <- TcM.newTcRef inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + + ; res <- thing_inside nest_env + + ; new_inerts <- TcM.readTcRef new_inert_var + + -- we want to propagate the safe haskell failures + ; let old_ic = inert_cans inerts + new_ic = inert_cans new_inerts + nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } + + ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] + (inerts { inert_solved_dicts = inert_solved_dicts new_inerts + , inert_cans = nxt_ic }) + + ; return res } + +emitImplicationTcS :: TcLevel -> SkolemInfoAnon + -> [TcTyVar] -- Skolems + -> [EvVar] -- Givens + -> Cts -- Wanteds + -> TcS TcEvBinds +-- Add an implication to the TcS monad work-list +emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds + = do { let wc = emptyWC { wc_simple = wanteds } + ; imp <- wrapTcS $ + do { ev_binds_var <- TcM.newTcEvBinds + ; imp <- TcM.newImplication + ; return (imp { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_given = givens + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_info = skol_info }) } + + ; emitImplication imp + ; return (TcEvBinds (ic_binds imp)) } + +emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon + -> [TcTyVar] -- Skolems + -> Cts -- Wanteds + -> TcS () +-- Just like emitImplicationTcS but no givens and no bindings +emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds + = do { let wc = emptyWC { wc_simple = wanteds } + ; imp <- wrapTcS $ + do { ev_binds_var <- TcM.newNoTcEvBinds + ; imp <- TcM.newImplication + ; return (imp { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_info = skol_info }) } + + ; emitImplication imp } + + +{- Note [Propagate the solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really quite important that nestTcS does not discard the solved +dictionaries from the thing_inside. +Consider + Eq [a] + forall b. empty => Eq [a] +We solve the simple (Eq [a]), under nestTcS, and then turn our attention to +the implications. It's definitely fine to use the solved dictionaries on +the inner implications, and it can make a significant performance difference +if you do so. +-} + +-- Getters and setters of GHC.Tc.Utils.Env fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- Getter of inerts and worklist +getInertSetRef :: TcS (IORef InertSet) +getInertSetRef = TcS (return . tcs_inerts) + +getInertSet :: TcS InertSet +getInertSet = getInertSetRef >>= readTcRef + +setInertSet :: InertSet -> TcS () +setInertSet is = do { r <- getInertSetRef; writeTcRef r is } + +getTcSWorkListRef :: TcS (IORef WorkList) +getTcSWorkListRef = TcS (return . tcs_worklist) + +getWorkListImplics :: TcS (Bag Implication) +getWorkListImplics + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- readTcRef wl_var + ; return (wl_implics wl_curr) } + +pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) +-- Push the level and run thing_inside +-- However, thing_inside should not generate any work items +#if defined(DEBUG) +pushLevelNoWorkList err_doc (TcS thing_inside) + = TcS (\env -> TcM.pushTcLevelM $ + thing_inside (env { tcs_worklist = wl_panic }) + ) + where + wl_panic = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc + -- This panic checks that the thing-inside + -- does not emit any work-list constraints +#else +pushLevelNoWorkList _ (TcS thing_inside) + = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check +#endif + +updWorkListTcS :: (WorkList -> WorkList) -> TcS () +updWorkListTcS f + = do { wl_var <- getTcSWorkListRef + ; updTcRef wl_var f } + +emitWorkNC :: [CtEvidence] -> TcS () +emitWorkNC evs + | null evs + = return () + | otherwise + = emitWork (listToBag (map mkNonCanonical evs)) + +emitWork :: Cts -> TcS () +emitWork cts + | isEmptyBag cts -- Avoid printing, among other work + = return () + | otherwise + = do { traceTcS "Emitting fresh work" (pprBag cts) + -- Zonk the rewriter set of Wanteds, because that affects + -- the prioritisation of the work-list. Suppose a constraint + -- c1 is rewritten by another, c2. When c2 gets solved, + -- c1 has no rewriters, and can be prioritised; see + -- Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint wrinkle (WRW1) + ; cts <- wrapTcS $ mapBagM TcM.zonkCtRewriterSet cts + ; updWorkListTcS (extendWorkListCts cts) } + +emitImplication :: Implication -> TcS () +emitImplication implic + = updWorkListTcS (extendWorkListImplic implic) + +newTcRef :: a -> TcS (TcRef a) +newTcRef x = wrapTcS (TcM.newTcRef x) + +readTcRef :: TcRef a -> TcS a +readTcRef ref = wrapTcS (TcM.readTcRef ref) + +writeTcRef :: TcRef a -> a -> TcS () +writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) + +updTcRef :: TcRef a -> (a->a) -> TcS () +updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) + +getTcEvBindsVar :: TcS EvBindsVar +getTcEvBindsVar = TcS (return . tcs_ev_binds) + +getTcLevel :: TcS TcLevel +getTcLevel = wrapTcS TcM.getTcLevel + +getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet +getTcEvTyCoVars ev_binds_var + = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var + +getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap +getTcEvBindsMap ev_binds_var + = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var + +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () +setTcEvBindsMap ev_binds_var binds + = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds + +unifyTyVar :: TcTyVar -> TcType -> TcS () +-- Unify a meta-tyvar with a type +-- We keep track of how many unifications have happened in tcs_unified, +-- +-- We should never unify the same variable twice! +unifyTyVar tv ty + = assertPpr (isMetaTyVar tv) (ppr tv) $ + TcS $ \ env -> + do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.liftZonkM $ TcM.writeMetaTyVar tv ty + ; TcM.updTcRef (tcs_unified env) (+1) } + +reportUnifications :: TcS a -> TcS (Int, a) +reportUnifications (TcS thing_inside) + = TcS $ \ env -> + do { inner_unified <- TcM.newTcRef 0 + ; res <- thing_inside (env { tcs_unified = inner_unified }) + ; n_unifs <- TcM.readTcRef inner_unified + ; TcM.updTcRef (tcs_unified env) (+ n_unifs) + ; return (n_unifs, res) } + +getDefaultInfo :: TcS ([Type], (Bool, Bool)) +getDefaultInfo = wrapTcS TcM.tcGetDefaultTys + +getWorkList :: TcS WorkList +getWorkList = do { wl_var <- getTcSWorkListRef + ; wrapTcS (TcM.readTcRef wl_var) } + +selectNextWorkItem :: TcS (Maybe Ct) +-- Pick which work item to do next +-- See Note [Prioritise equalities] +selectNextWorkItem + = do { wl_var <- getTcSWorkListRef + ; wl <- readTcRef wl_var + ; case selectWorkItem wl of { + Nothing -> return Nothing ; + Just (ct, new_wl) -> + do { -- checkReductionDepth (ctLoc ct) (ctPred ct) + -- This is done by GHC.Tc.Solver.Dict.chooseInstance + ; writeTcRef wl_var new_wl + ; return (Just ct) } } } + +-- Just get some environments needed for instance looking up and matching +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +getInstEnvs :: TcS InstEnvs +getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs + +getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) +getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs + +getTopEnv :: TcS HscEnv +getTopEnv = wrapTcS $ TcM.getTopEnv + +getGblEnv :: TcS TcGblEnv +getGblEnv = wrapTcS $ TcM.getGblEnv + +getLclEnv :: TcS TcLclEnv +getLclEnv = wrapTcS $ TcM.getLclEnv + +setSrcSpan :: RealSrcSpan -> TcS a -> TcS a +setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty)) + +tcLookupClass :: Name -> TcS Class +tcLookupClass c = wrapTcS $ TcM.tcLookupClass c + +tcLookupId :: Name -> TcS Id +tcLookupId n = wrapTcS $ TcM.tcLookupId n + +tcLookupTyCon :: Name -> TcS TyCon +tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n + +-- Any use of this function is a bit suspect, because it violates the +-- pure veneer of TcS. But it's just about warnings around unused imports +-- and local constructors (GHC will issue fewer warnings than it otherwise +-- might), so it's not worth losing sleep over. +recordUsedGREs :: Bag GlobalRdrElt -> TcS () +recordUsedGREs gres + = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list + -- If a newtype constructor was imported, don't warn about not + -- importing it... + ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list } + -- ...and similarly, if a newtype constructor was defined in the same + -- module, don't warn about it being unused. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. + + where + gre_list = bagToList gres + +-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () +-- Check that we do not try to use an instance before it is available. E.g. +-- instance Eq T where ... +-- f x = $( ... (\(p::T) -> p == p)... ) +-- Here we can't use the equality function from the instance in the splice + +checkWellStagedDFun loc what pred + = do + mbind_lvl <- checkWellStagedInstanceWhat what + case mbind_lvl of + Just bind_lvl | bind_lvl > impLevel -> + wrapTcS $ TcM.setCtLocM loc $ do + { use_stage <- TcM.getStage + ; TcM.checkWellStaged (StageCheckInstance what pred) bind_lvl (thLevel use_stage) } + _ -> + return () + +-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence) +-- See Note [Well-staged instance evidence] +checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel) +checkWellStagedInstanceWhat what + | TopLevInstance { iw_dfun_id = dfun_id } <- what + = return $ Just (TcM.topIdLvl dfun_id) + | BuiltinTypeableInstance tc <- what + = do + cur_mod <- extractModule <$> getGblEnv + return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc) + then outerLevel + else impLevel) + | otherwise = return Nothing + +{- +Note [Well-staged instance evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Evidence for instances must obey the same level restrictions as normal bindings. +In particular, it is forbidden to use an instance in a top-level splice in the +module which the instance is defined. This is because the evidence is bound at +the top-level and top-level definitions are forbidden from being using in top-level splices in +the same module. + +For example, suppose you have a function.. foo :: Show a => Code Q a -> Code Q () +then the following program is disallowed, + +``` +data T a = T a deriving (Show) + +main :: IO () +main = + let x = $$(foo [|| T () ||]) + in return () +``` + +because the `foo` function (used in a top-level splice) requires `Show T` evidence, +which is defined at the top-level and therefore fails with an error that we have violated +the stage restriction. + +``` +Main.hs:12:14: error: + • GHC stage restriction: + instance for ‘Show + (T ())’ is used in a top-level splice, quasi-quote, or annotation, + and must be imported, not defined locally + • In the expression: foo [|| T () ||] + In the Template Haskell splice $$(foo [|| T () ||]) + In the expression: $$(foo [|| T () ||]) + | +12 | let x = $$(foo [|| T () ||]) + | +``` + +Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on +`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT` +is well staged. It's easy to know the stage of `$tcT`: for imported TyCons it +will be `impLevel`, and for local TyCons it will be `toplevel`. + +Therefore the `InstanceWhat` type had to be extended with +a special case for `Typeable`, which recorded the TyCon the evidence was for and +could them be used to check that we were not attempting to evidence in a stage incorrect +manner. + +-} + +pprEq :: TcType -> TcType -> SDoc +pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 + +isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) +isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) + +isFilledMetaTyVar :: TcTyVar -> TcS Bool +isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) + +zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet +zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs) + +zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] +zonkTyCoVarsAndFVList tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFVList tvs) + +zonkCo :: Coercion -> TcS Coercion +zonkCo = wrapTcS . fmap TcM.liftZonkM TcM.zonkCo + +zonkTcType :: TcType -> TcS TcType +zonkTcType ty = liftZonkTcS (TcM.zonkTcType ty) + +zonkTcTypes :: [TcType] -> TcS [TcType] +zonkTcTypes tys = liftZonkTcS (TcM.zonkTcTypes tys) + +zonkTcTyVar :: TcTyVar -> TcS TcType +zonkTcTyVar tv = liftZonkTcS (TcM.zonkTcTyVar tv) + +zonkSimples :: Cts -> TcS Cts +zonkSimples cts = liftZonkTcS (TcM.zonkSimples cts) + +zonkWC :: WantedConstraints -> TcS WantedConstraints +zonkWC wc = liftZonkTcS (TcM.zonkWC wc) + +zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar +zonkTyCoVarKind tv = liftZonkTcS (TcM.zonkTyCoVarKind tv) + +---------------------------- +pprKicked :: Int -> SDoc +pprKicked 0 = empty +pprKicked n = parens (int n <+> text "kicked out") + +{- ********************************************************************* +* * +* The Unification Level Flag * +* * +********************************************************************* -} + +{- Note [The Unification Level Flag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a deep tree of implication constraints + forall[1] a. -- Outer-implic + C alpha[1] -- Simple + forall[2] c. ....(C alpha[1]).... -- Implic-1 + forall[2] b. ....(alpha[1] ~ Int).... -- Implic-2 + +The (C alpha) is insoluble until we know alpha. We solve alpha +by unifying alpha:=Int somewhere deep inside Implic-2. But then we +must try to solve the Outer-implic all over again. This time we can +solve (C alpha) both in Outer-implic, and nested inside Implic-1. + +When should we iterate solving a level-n implication? +Answer: if any unification of a tyvar at level n takes place + in the ic_implics of that implication. + +* What if a unification takes place at level n-1? Then don't iterate + level n, because we'll iterate level n-1, and that will in turn iterate + level n. + +* What if a unification takes place at level n, in the ic_simples of + level n? No need to track this, because the kick-out mechanism deals + with it. (We can't drop kick-out in favour of iteration, because kick-out + works for skolem-equalities, not just unifications.) + +So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps +track of + - Whether any unifications at all have taken place (Nothing => no unifications) + - If so, what is the outermost level that has seen a unification (Just lvl) + +The iteration is done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver. + +It helpful not to iterate unless there is a chance of progress. #8474 is +an example: + + * There's a deeply-nested chain of implication constraints. + ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int + + * From the innermost one we get a [W] alpha[1] ~ Int, + so we can unify. + + * It's better not to iterate the inner implications, but go all the + way out to level 1 before iterating -- because iterating level 1 + will iterate the inner levels anyway. + +(In the olden days when we "floated" thse Derived constraints, this was +much, much more important -- we got exponential behaviour, as each iteration +produced the same Derived constraint.) +-} + + +resetUnificationFlag :: TcS Bool +-- We are at ambient level i +-- If the unification flag = Just i, reset it to Nothing and return True +-- Otherwise leave it unchanged and return False +resetUnificationFlag + = TcS $ \env -> + do { let ref = tcs_unif_lvl env + ; ambient_lvl <- TcM.getTcLevel + ; mb_lvl <- TcM.readTcRef ref + ; TcM.traceTc "resetUnificationFlag" $ + vcat [ text "ambient:" <+> ppr ambient_lvl + , text "unif_lvl:" <+> ppr mb_lvl ] + ; case mb_lvl of + Nothing -> return False + Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl + -> return False + | otherwise + -> do { TcM.writeTcRef ref Nothing + ; return True } } + +setUnificationFlag :: TcLevel -> TcS () +-- (setUnificationFlag i) sets the unification level to (Just i) +-- unless it already is (Just j) where j <= i +setUnificationFlag lvl + = TcS $ \env -> + do { let ref = tcs_unif_lvl env + ; mb_lvl <- TcM.readTcRef ref + ; case mb_lvl of + Just unif_lvl | lvl `deeperThanOrSame` unif_lvl + -> return () + _ -> TcM.writeTcRef ref (Just lvl) } + + +{- ********************************************************************* +* * +* Instantiation etc. +* * +********************************************************************* -} + +-- Instantiations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) +instDFunType dfun_id inst_tys + = wrapTcS $ TcM.instDFunType dfun_id inst_tys + +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + +instFlexiX :: Subst -> [TKVar] -> TcS Subst +instFlexiX subst tvs = wrapTcS (instFlexiXTcM subst tvs) + +instFlexiXTcM :: Subst -> [TKVar] -> TcM Subst +-- Makes fresh tyvar, extends the substitution, and the in-scope set +-- Takes account of the case [k::Type, a::k, ...], +-- where we must substitute for k in a's kind +instFlexiXTcM subst [] + = return subst +instFlexiXTcM subst (tv:tvs) + = do { uniq <- TcM.newUnique + ; details <- TcM.newMetaDetails TauTv + ; let name = setNameUnique (tyVarName tv) uniq + kind = substTyUnchecked subst (tyVarKind tv) + tv' = mkTcTyVar name kind details + subst' = extendTvSubstWithClone subst tv tv' + ; instFlexiXTcM subst' tvs } + +matchGlobalInst :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcS TcM.ClsInstResult +matchGlobalInst dflags short_cut cls tys + = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) + +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) +tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs + +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data MaybeNew = Fresh CtEvidence | Cached EvExpr + +isFresh :: MaybeNew -> Bool +isFresh (Fresh {}) = True +isFresh (Cached {}) = False + +freshGoals :: [MaybeNew] -> [CtEvidence] +freshGoals mns = [ ctev | Fresh ctev <- mns ] + +getEvExpr :: MaybeNew -> EvExpr +getEvExpr (Fresh ctev) = ctEvExpr ctev +getEvExpr (Cached evt) = evt + +setEvBind :: EvBind -> TcS () +setEvBind ev_bind + = do { evb <- getTcEvBindsVar + ; wrapTcS $ TcM.addTcEvBind evb ev_bind } + +-- | Mark variables as used filling a coercion hole +useVars :: CoVarSet -> TcS () +useVars co_vars + = do { ev_binds_var <- getTcEvBindsVar + ; let ref = ebv_tcvs ev_binds_var + ; wrapTcS $ + do { tcvs <- TcM.readTcRef ref + ; let tcvs' = tcvs `unionVarSet` co_vars + ; TcM.writeTcRef ref tcvs' } } + +-- | Equalities only +setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS () +setWantedEq (HoleDest hole) co + = do { useVars (coVarsOfCo co) + ; fillCoercionHole hole co } +setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) + +-- | Good for both equalities and non-equalities +setWantedEvTerm :: TcEvDest -> Canonical -> EvTerm -> TcS () +setWantedEvTerm (HoleDest hole) _canonical tm + | Just co <- evTermCoercion_maybe tm + = do { useVars (coVarsOfCo co) + ; fillCoercionHole hole co } + | otherwise + = -- See Note [Yukky eq_sel for a HoleDest] + do { let co_var = coHoleCoVar hole + ; setEvBind (mkWantedEvBind co_var True tm) + ; fillCoercionHole hole (mkCoVarCo co_var) } + +setWantedEvTerm (EvVarDest ev_id) canonical tm + = setEvBind (mkWantedEvBind ev_id canonical tm) + +{- Note [Yukky eq_sel for a HoleDest] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How can it be that a Wanted with HoleDest gets evidence that isn't +just a coercion? i.e. evTermCoercion_maybe returns Nothing. + +Consider [G] forall a. blah => a ~ T + [W] S ~# T + +Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T) +in the quantified constraints, and wraps the (boxed) evidence it +gets back in an eq_sel to extract the unboxed (S ~# T). We can't put +that term into a coercion, so we add a value binding + h = eq_sel (...) +and the coercion variable h to fill the coercion hole. +We even re-use the CoHole's Id for this binding! + +Yuk! +-} + +fillCoercionHole :: CoercionHole -> Coercion -> TcS () +fillCoercionHole hole co + = do { wrapTcS $ TcM.fillCoercionHole hole co + ; kickOutAfterFillingCoercionHole hole } + +setEvBindIfWanted :: CtEvidence -> Canonical -> EvTerm -> TcS () +setEvBindIfWanted ev canonical tm + = case ev of + CtWanted { ctev_dest = dest } -> setWantedEvTerm dest canonical tm + _ -> return () + +newTcEvBinds :: TcS EvBindsVar +newTcEvBinds = wrapTcS TcM.newTcEvBinds + +newNoTcEvBinds :: TcS EvBindsVar +newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds + +newEvVar :: TcPredType -> TcS EvVar +newEvVar pred = wrapTcS (TcM.newEvVar pred) + +newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence +-- Make a new variable of the given PredType, +-- immediately bind it to the given term +-- and return its CtEvidence +-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint +newGivenEvVar loc (pred, rhs) + = do { new_ev <- newBoundEvVarId pred rhs + ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } + +-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the +-- given term +newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar +newBoundEvVarId pred rhs + = do { new_ev <- newEvVar pred + ; setEvBind (mkGivenEvBind new_ev rhs) + ; return new_ev } + +emitNewGivens :: CtLoc -> [(Role,TcType,TcType,TcCoercion)] -> TcS () +emitNewGivens loc pts + = do { evs <- mapM (newGivenEvVar loc) $ + [ (mkPrimEqPredRole role ty1 ty2, evCoercion co) + | (role, ty1, ty2, co) <- pts + , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth + ; emitWorkNC evs } + +emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion +-- | Emit a new Wanted equality into the work-list +emitNewWantedEq loc rewriters role ty1 ty2 + = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2 + ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical ev)) + ; return co } + +-- | Create a new Wanted constraint holding a coercion hole +-- for an equality between the two types at the given 'Role'. +newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq loc rewriters role ty1 ty2 + = do { hole <- wrapTcS $ TcM.newCoercionHole loc pty + ; return ( CtWanted { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } + , mkHoleCo hole ) } + where + pty = mkPrimEqPredRole role ty1 ty2 + +-- | Create a new Wanted constraint holding an evidence variable. +-- +-- Don't use this for equality constraints: use 'newWantedEq' instead. +newWantedEvVarNC :: CtLoc -> RewriterSet + -> TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC loc rewriters pty + = do { new_ev <- newEvVar pty + ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ + pprCtLoc loc) + ; return (CtWanted { ctev_pred = pty + , ctev_dest = EvVarDest new_ev + , ctev_loc = loc + , ctev_rewriters = rewriters })} + +-- | Like 'newWantedEvVarNC', except it might look up in the inert set +-- to see if an inert already exists, and uses that instead of creating +-- a new Wanted constraint. +-- +-- Don't use this for equality constraints: this function is only for +-- constraints with 'EvVarDest'. +newWantedEvVar :: CtLoc -> RewriterSet + -> TcPredType -> TcS MaybeNew +-- For anything except ClassPred, this is the same as newWantedEvVarNC +newWantedEvVar loc rewriters pty + = assertPpr (not (isEqPrimPred pty)) + (vcat [ text "newWantedEvVar: HoleDestPred" + , text "pty:" <+> ppr pty ]) $ + do { mb_ct <- lookupInInerts loc pty + ; case mb_ct of + Just ctev + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev + ; return $ Cached (ctEvExpr ctev) } + _ -> do { ctev <- newWantedEvVarNC loc rewriters pty + ; return (Fresh ctev) } } + +-- | Create a new Wanted constraint, potentially looking up +-- non-equality constraints in the cache instead of creating +-- a new one from scratch. +-- +-- Deals with both equality and non-equality constraints. +newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew +newWanted loc rewriters pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2 + | otherwise + = newWantedEvVar loc rewriters pty + +-- | Create a new Wanted constraint. +-- +-- Deals with both equality and non-equality constraints. +-- +-- Does not attempt to re-use non-equality constraints that already +-- exist in the inert set. +newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence +newWantedNC loc rewriters pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = fst <$> newWantedEq loc rewriters role ty1 ty2 + | otherwise + = newWantedEvVarNC loc rewriters pty + +-- | Checks if the depth of the given location is too much. Fails if +-- it's too big, with an appropriate error message. +checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced + -> TcS () +checkReductionDepth loc ty + = do { dflags <- getDynFlags + ; when (subGoalDepthExceeded (reductionDepth dflags) (ctLocDepth loc)) $ + wrapErrTcS $ solverDepthError loc ty } + +matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN) +matchFam tycon args = wrapTcS $ matchFamTcM tycon args + +matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN) +-- Given (F tys) return (ty, co), where co :: F tys ~N ty +matchFamTcM tycon args + = do { fam_envs <- FamInst.tcGetFamInstEnvs + ; let match_fam_result + = reduceTyFamApp_maybe fam_envs Nominal tycon args + ; TcM.traceTc "matchFamTcM" $ + vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) + , ppr_res match_fam_result ] + ; return match_fam_result } + where + ppr_res Nothing = text "Match failed" + ppr_res (Just (Reduction co ty)) + = hang (text "Match succeeded:") + 2 (vcat [ text "Rewrites to:" <+> ppr ty + , text "Coercion:" <+> ppr co ]) + +solverDepthError :: CtLoc -> TcType -> TcM a +solverDepthError loc ty + = TcM.setCtLocM loc $ + do { (ty, env0) <- TcM.liftZonkM $ + do { ty <- TcM.zonkTcType ty + ; env0 <- TcM.tcInitTidyEnv + ; return (ty, env0) } + ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) + tidy_ty = tidyType tidy_env ty + msg = TcRnSolverDepthError tidy_ty depth + ; TcM.failWithTcM (tidy_env, msg) } + where + depth = ctLocDepth loc + +{- +************************************************************************ +* * + Emitting equalities arising from fundeps +* * +************************************************************************ +-} + +emitFunDepWanteds :: CtEvidence -- The work item + -> [FunDepEqn (CtLoc, RewriterSet)] + -> TcS Bool -- True <=> some unification happened + +emitFunDepWanteds _ [] = return False -- common case noop +-- See Note [FunDep and implicit parameter reactions] + +emitFunDepWanteds ev fd_eqns + = unifyFunDeps ev Nominal do_fundeps + where + do_fundeps :: UnifyEnv -> TcM () + do_fundeps env = mapM_ (do_one env) fd_eqns + + do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM () + do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) + = do { eqs' <- instantiate_eqs tvs (reverse eqs) + -- (reverse eqs): See Note [Reverse order of fundep equations] + ; uPairsTcM env_one eqs' } + where + env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters + , u_loc = loc } + + instantiate_eqs :: [TyVar] -> [TypeEqn] -> TcM [TypeEqn] + instantiate_eqs tvs eqs + | null tvs + = return eqs + | otherwise + = do { TcM.traceTc "emitFunDepWanteds 2" (ppr tvs $$ ppr eqs) + ; subst <- instFlexiXTcM emptySubst tvs -- Takes account of kind substitution + ; return [ Pair (substTyUnchecked subst' ty1) ty2 + -- ty2 does not mention fd_qtvs, so no need to subst it. + -- See GHC.Tc.Instance.Fundeps Note [Improving against instances] + -- Wrinkle (1) + | Pair ty1 ty2 <- eqs + , let subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) ] + -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result + -- of matching with the [W] constraint. So we add its free + -- vars to InScopeSet, to satisfy substTy's invariants, even + -- though ty1 will never (currently) be a poytype, so this + -- InScopeSet will never be looked at. + } + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [wrapUnifierTcS] +~~~~~~~~~~~~~~~~~~~ +When decomposing equalities we often create new wanted constraints for +(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. + +Rather than making an equality test (which traverses the structure of the type, +perhaps fruitlessly), we call uType (via wrapUnifierTcS) to traverse the common +structure, and bales out when it finds a difference by creating a new deferred +Wanted constraint. But where it succeeds in finding common structure, it just +builds a coercion to reflect it. + +This is all much faster than creating a new constraint, putting it in the +work list, picking it out, canonicalising it, etc etc. + +Note [unifyFunDeps] +~~~~~~~~~~~~~~~~~~~ +The Bool returned by `unifyFunDeps` is True if we have unified a variable +that occurs in the constraint we are trying to solve; it is not in the +inert set so `wrapUnifierTcS` won't kick it out. Instead we want to send it +back to the start of the pipeline. Hence the Bool. + +It's vital that we don't return (not (null unified)) because the fundeps +may create fresh variables; unifying them (alone) should not make us send +the constraint back to the start, or we'll get an infinite loop. See +Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict +and Note [Improvement orientation] in GHC.Tc.Solver.Equality. +-} + +uPairsTcM :: UnifyEnv -> [TypeEqn] -> TcM () +uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns + +unifyFunDeps :: CtEvidence -> Role + -> (UnifyEnv -> TcM ()) + -> TcS Bool +unifyFunDeps ev role do_unifications + = do { (_, _, unified) <- wrapUnifierTcS ev role do_unifications + ; return (any (`elemVarSet` fvs) unified) } + -- See Note [unifyFunDeps] + where + fvs = tyCoVarsOfType (ctEvPred ev) + +wrapUnifierTcS :: CtEvidence -> Role + -> (UnifyEnv -> TcM a) -- Some calls to uType + -> TcS (a, Bag Ct, [TcTyVar]) +-- Invokes the do_unifications argument, with a suitable UnifyEnv. +-- Emit deferred equalities and kick-out from the inert set as a +-- result of any unifications. +-- Very good short-cut when the two types are equal, or nearly so +-- See Note [wrapUnifierTcS] +-- +-- The [TcTyVar] is the list of unification variables that were +-- unified the process; the (Bag Ct) are the deferred constraints. + +wrapUnifierTcS ev role do_unifications + = do { (cos, unified, rewriters, cts) <- wrapTcS $ + do { defer_ref <- TcM.newTcRef emptyBag + ; unified_ref <- TcM.newTcRef [] + ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev) + ; let env = UE { u_role = role + , u_rewriters = rewriters + , u_loc = ctEvLoc ev + , u_defer = defer_ref + , u_unified = Just unified_ref} + + ; cos <- do_unifications env + + ; cts <- TcM.readTcRef defer_ref + ; unified <- TcM.readTcRef unified_ref + ; return (cos, unified, rewriters, cts) } + + -- Emit the deferred constraints + -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality + ; unless (isEmptyBag cts) $ + updWorkListTcS (extendWorkListEqs rewriters cts) + + -- And kick out any inert constraint that we have unified + ; _ <- kickOutAfterUnification unified + + ; return (cos, cts, unified) } + + +{- +************************************************************************ +* * + Breaking type variable cycles +* * +************************************************************************ +-} + +checkTouchableTyVarEq + :: CtEvidence + -> TcTyVar -- A touchable meta-tyvar + -> TcType -- The RHS + -> TcS (PuResult () Reduction) +-- Used for Nominal, Wanted equalities, with a touchable meta-tyvar on LHS +-- If checkTouchableTyVarEq tv ty = PuOK cts redn +-- then we can unify +-- tv := ty |> redn +-- with extra wanteds 'cts' +-- If it returns (PuFail reason) we can't unify, and the reason explains why. +checkTouchableTyVarEq ev lhs_tv rhs + | simpleUnifyCheck True lhs_tv rhs + -- True <=> type families are ok on the RHS + = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs) + ; return (pure (mkReflRedn Nominal rhs)) } + + | otherwise + = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs) + ; check_result <- wrapTcS (check_rhs rhs) + ; traceTcS "checkTouchableTyVarEq }" (ppr lhs_tv $$ ppr check_result) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK cts redn -> do { emitWork cts + ; return (pure redn) } } + + where + (lhs_tv_info, lhs_tv_lvl) = case tcTyVarDetails lhs_tv of + MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl) + _ -> pprPanic "checkTouchableTyVarEq" (ppr lhs_tv) + -- lhs_tv should be a meta-tyvar + + is_concrete_lhs_tv = isConcreteInfo lhs_tv_info + + check_rhs rhs + -- Crucial special case for alpha ~ F tys + -- We don't want to flatten that (F tys)! + | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs + = if is_concrete_lhs_tv + then failCheckWith (cteProblem cteConcrete) + else recurseIntoTyConApp arg_flags tc tys + | otherwise + = checkTyEqRhs flags rhs + + flags = TEF { tef_foralls = False -- isRuntimeUnkSkol lhs_tv + , tef_fam_app = mkTEFA_Break ev NomEq break_wanted + , tef_unifying = Unifying lhs_tv_info lhs_tv_lvl LC_Promote + , tef_lhs = TyVarLHS lhs_tv + , tef_occurs = cteInsolubleOccurs } + + arg_flags = famAppArgFlags flags + + break_wanted fam_app + -- Occurs check or skolem escape; so flatten + = do { let fam_app_kind = typeKind fam_app + ; reason <- checkPromoteFreeVars cteInsolubleOccurs + lhs_tv lhs_tv_lvl (tyCoVarsOfType fam_app_kind) + ; if not (cterHasNoProblem reason) -- Failed to promote free vars + then failCheckWith reason + else + do { new_tv_ty <- + case lhs_tv_info of + ConcreteTv conc_info -> + -- Make a concrete tyvar if lhs_tv is concrete + -- e.g. alpha[2,conc] ~ Maybe (F beta[4]) + -- We want to flatten to + -- alpha[2,conc] ~ Maybe gamma[2,conc] + -- gamma[2,conc] ~ F beta[4] + TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind + _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind + + ; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty + ; hole <- TcM.newVanillaCoercionHole pty + ; let new_ev = CtWanted { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = cb_loc + , ctev_rewriters = ctEvRewriters ev } + ; return (PuOK (singleCt (mkNonCanonical new_ev)) + (mkReduction (HoleCo hole) new_tv_ty)) } } + + -- See Detail (7) of the Note + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin + +------------------------ +checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType + -> TcS (PuResult () Reduction) +-- Used for general CanEqLHSs, ones that do +-- not have a touchable type variable on the LHS (i.e. not unifying) +checkTypeEq ev eq_rel lhs rhs + | isGiven ev + = do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ]) + ; check_result <- wrapTcS (check_given_rhs rhs) + ; traceTcS "checkTypeEq }" (ppr check_result) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs + ; emitWork new_givens + ; updInertSet (addCycleBreakerBindings prs) + ; return (pure redn) } } + + | otherwise -- Wanted + = do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK cts redn -> do { emitWork cts + ; return (pure redn) } } + where + check_given_rhs :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction) + check_given_rhs rhs + -- See Note [Special case for top-level of Given equality] + | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs + = recurseIntoTyConApp arg_flags tc tys + | otherwise + = checkTyEqRhs given_flags rhs + + arg_flags = famAppArgFlags given_flags + + given_flags :: TyEqFlags (TcTyVar,TcType) + given_flags = TEF { tef_lhs = lhs + , tef_foralls = False + , tef_unifying = NotUnifying + , tef_fam_app = mkTEFA_Break ev eq_rel break_given + , tef_occurs = occ_prob } + -- TEFA_Break used for: [G] a ~ Maybe (F a) + -- or [W] F a ~ Maybe (F a) + + wanted_flags = TEF { tef_lhs = lhs + , tef_foralls = False + , tef_unifying = NotUnifying + , tef_fam_app = TEFA_Recurse + , tef_occurs = occ_prob } + -- TEFA_Recurse: see Note [Don't cycle-break Wanteds when not unifying] + + -- occ_prob: see Note [Occurs check and representational equality] + occ_prob = case eq_rel of + NomEq -> cteInsolubleOccurs + ReprEq -> cteSolubleOccurs + + break_given :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction) + break_given fam_app + = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app) + ; return (PuOK (unitBag (new_tv, fam_app)) + (mkReflRedn Nominal (mkTyVarTy new_tv))) } + -- Why reflexive? See Detail (4) of the Note + + --------------------------- + mk_new_given :: (TcTyVar, TcType) -> TcS Ct + mk_new_given (new_tv, fam_app) + = mkNonCanonical <$> newGivenEvVar cb_loc (given_pred, given_term) + where + new_ty = mkTyVarTy new_tv + given_pred = mkPrimEqPred fam_app new_ty + given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note + + -- See Detail (7) of the Note + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin + +mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp a +mkTEFA_Break ev eq_rel breaker + | NomEq <- eq_rel + , not cycle_breaker_origin + = TEFA_Break breaker + | otherwise + = TEFA_Recurse + where + -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles] + -- in GHC.Tc.Solver.Equality + cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of + CycleBreakerOrigin {} -> True + _ -> False + +------------------------- +-- | Fill in CycleBreakerTvs with the variables they stand for. +-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality +restoreTyVarCycles :: InertSet -> TcM () +restoreTyVarCycles is + = TcM.liftZonkM + $ forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar +{-# SPECIALISE forAllCycleBreakerBindings_ :: + CycleBreakerVarStack -> (TcTyVar -> TcType -> ZonkM ()) -> ZonkM () #-} + + +{- Note [Occurs check and representational equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(a ~R# b a) is soluble if b later turns out to be Identity +So we treat this as a "soluble occurs check". + +Note [Special case for top-level of Given equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care when examining + [G] F ty ~ G (...(F ty)...) +where both sides are TyFamLHSs. We don't want to flatten that RHS to + [G] F ty ~ cbv + [G] G (...(F ty)...) ~ cbv +Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a +canonical constraint + [G] G (...(F ty)...) ~ F ty +That tents to rewrite a big type to smaller one. This happens in T15703, +where we had: + [G] Pure g ~ From1 (To1 (Pure g)) +Making a loop breaker and rewriting left to right just makes much bigger +types than swapping it over. + +(We might hope to have swapped it over before getting to checkTypeEq, +but better safe than sorry.) + +NB: We never see a TyVarLHS here, such as + [G] a ~ F tys here +because we'd have swapped it to + [G] F tys ~ a +in canEqCanLHS2, before getting to checkTypeEq. + +Note [Don't cycle-break Wanteds when not unifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consdier + [W] a[2] ~ Maybe (F a[2]) + +Should we cycle-break this Wanted, thus? + + [W] a[2] ~ Maybe delta[2] + [W] delta[2] ~ F a[2] + +For a start, this is dodgy because we might just unify delta, thus undoing +what we have done, and getting an infinite loop in the solver. Even if we +somehow prevented ourselves from doing so, is there any merit in the split? +Maybe: perhaps we can use that equality on `a` to unlock other constraints? +Consider + type instance F (Maybe _) = Bool + + [G] g1: a ~ Maybe Bool + [W] w1: a ~ Maybe (F a) + +If we loop-break w1 to get + [W] w1': a ~ Maybe gamma + [W] w3: gamma ~ F a +Now rewrite w3 with w1' + [W] w3': gamma ~ F (Maybe gamma) +Now use the type instance to get + gamma := Bool +Now we are left with + [W] w1': a ~ Maybe Bool +which we can solve from the Given. + +BUT in this situation we could have rewritten the +/original/ Wanted from the Given, like this: + [W] w1': Maybe Bool ~ Maybe (F (Maybe Bool)) +and that is readily soluble. + +In short: loop-breaking Wanteds, when we aren't unifying, +seems of no merit. Hence TEFA_Recurse, rather than TEFA_Break, +in `wanted_flags` in `checkTypeEq`. +-} diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -27,7 +27,7 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -41,6 +41,7 @@ import GHC.Builtin.Types (tYPETyCon) import Data.List ( find ) import GHC.Data.List.Infinite (Infinite) +import GHC.Data.Bag( listToBag ) import qualified GHC.Data.List.Infinite as Inf {- @@ -55,7 +56,6 @@ -- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv' newtype RewriteM a = RewriteM { runRewriteM :: RewriteEnv -> TcS a } - deriving (Functor) -- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state -- monad trick] in "GHC.Utils.Monad". @@ -72,6 +72,9 @@ pure x = mkRewriteM $ \_ -> pure x (<*>) = ap +instance Functor RewriteM where + fmap f (RewriteM x) = mkRewriteM $ \env -> fmap f (x env) + instance HasDynFlags RewriteM where getDynFlags = liftTcS getDynFlags @@ -91,9 +94,9 @@ runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside = do { rewriters_ref <- newTcRef emptyRewriterSet - ; let fmode = RE { re_loc = loc - , re_flavour = flav - , re_eq_rel = eq_rel + ; let fmode = RE { re_loc = loc + , re_flavour = flav + , re_eq_rel = eq_rel , re_rewriters = rewriters_ref } ; res <- runRewriteM thing_inside fmode ; rewriters <- readTcRef rewriters_ref @@ -155,7 +158,7 @@ -- Precondition: the CtEvidence is a CtWanted of an equality recordRewriter :: CtEvidence -> RewriteM () recordRewriter (CtWanted { ctev_dest = HoleDest hole }) - = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriterSet` hole) + = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole) recordRewriter other = pprPanic "recordRewriter" (ppr other) {- @@ -315,7 +318,7 @@ Why have these invariants on rewriting? Because we sometimes use typeKind during canonicalisation, and we want this kind to be zonked (e.g., see -GHC.Tc.Solver.Canonical.canEqCanLHS). +GHC.Tc.Solver.Equality.canEqCanLHS). Rewriting is always homogeneous. That is, the kind of the result of rewriting is always the same as the kind of the input, modulo zonking. More formally: @@ -513,7 +516,7 @@ -- Important: look at the *reduced* type, so that any unzonked variables -- in kinds are gone and the getRuntimeRep succeeds. - -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical. + -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Equality. ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn) res_rep = getRuntimeRep (reductionReducedType res_redn) @@ -667,7 +670,7 @@ {- Note [Do not rewrite newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Canonical +We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Equality Note [Unwrap newtypes first]. But that turned out to be a bad idea because of recursive newtypes, as that Note says. So be careful if you re-add it! @@ -945,7 +948,7 @@ TcPluginRewriteTo { tcPluginReduction = redn , tcRewriterNewWanteds = wanteds - } -> do { emitWork wanteds; return $ Just redn } + } -> do { emitWork (listToBag wanteds); return $ Just redn } TcPluginNoRewrite {} -> runRewriters givens rewriters {- @@ -1012,9 +1015,9 @@ ; case lookupDVarEnv ieqs tv of Just equal_ct_list | Just ct <- find can_rewrite equal_ct_list - , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv - , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct - -> do { let wrw = isWantedCt ct + , EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv + , eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct + -> do { let wrw = isWanted ctev ; traceRewriteM "Following inert tyvar" $ vcat [ ppr tv <+> equals <+> ppr rhs_ty , ppr ctev @@ -1035,8 +1038,8 @@ _other -> return RTRNotFollowed } where - can_rewrite :: Ct -> Bool - can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr + can_rewrite :: EqCt -> Bool + can_rewrite ct = eqCtFlavourRole ct `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR {- @@ -1056,8 +1059,9 @@ [G] b ~ Maybe c This avoids "saturating" the Givens, which can save a modest amount of work. -It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert -only if (a) the work item can rewrite the inert AND +It is easy to implement, in GHC.Tc.Solver.InertSet.kickOutRewritableLHS, by +only kicking out an inert only if + (a) the work item can rewrite the inert AND (b) the inert cannot rewrite the work item This is significantly harder to think about. It can save a LOT of work @@ -1097,7 +1101,7 @@ where go (Bndr tv (NamedTCB vis)) (bndrs, _) = (Named (Bndr tv vis) : bndrs, True) - go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon (tymult (tyVarKind tv)) af : bndrs, n) + go (Bndr tv AnonTCB) (bndrs, n) + = (Anon (tymult (tyVarKind tv)) FTF_T_T : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/GHC/Tc/Solver/Solve.hs b/compiler/GHC/Tc/Solver/Solve.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Solve.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Solve ( + solveSimpleGivens, -- Solves [Ct] + solveSimpleWanteds -- Solves Cts + ) where + +import GHC.Prelude + +import GHC.Tc.Solver.Dict +import GHC.Tc.Solver.Equality( solveEquality ) +import GHC.Tc.Solver.Irred( solveIrred ) +import GHC.Tc.Solver.Rewrite( rewrite ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad + +import GHC.Core.Predicate +import GHC.Core.Reduction +import GHC.Core.Coercion +import GHC.Core.Class( classHasSCs ) + +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic ( IntWithInf, intGtLimit ) + +import GHC.Data.Bag + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import GHC.Driver.Session + +import Data.List( deleteFirstsBy ) + +import Control.Monad +import Data.Semigroup as S +import Data.Void( Void ) + +{- +********************************************************************** +* * +* Main Solver * +* * +********************************************************************** + +Note [Basic Simplifier Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Pick an element from the WorkList if there exists one with depth + less than our context-stack depth. + +2. Run it down the 'stage' pipeline. Stages are: + - canonicalization + - inert reactions + - spontaneous reactions + - top-level interactions + Each stage returns a StopOrContinue and may have sideeffected + the inerts or worklist. + + The threading of the stages is as follows: + - If (Stop) is returned by a stage then we start again from Step 1. + - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to + the next stage in the pipeline. +4. If the element has survived (i.e. ContinueWith x) the last stage + then we add it in the inerts and jump back to Step 1. + +If in Step 1 no such element exists, we have exceeded our context-stack +depth and will simply fail. +-} + +solveSimpleGivens :: [Ct] -> TcS () +solveSimpleGivens givens + | null givens -- Shortcut for common case + = return () + | otherwise + = do { traceTcS "solveSimpleGivens {" (ppr givens) + ; go givens + ; traceTcS "End solveSimpleGivens }" empty } + where + go givens = do { solveSimples (listToBag givens) + ; new_givens <- runTcPluginsGiven + ; when (notNull new_givens) $ + go new_givens } + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +-- The result is not necessarily zonked +solveSimpleWanteds simples + = do { traceTcS "solveSimpleWanteds {" (ppr simples) + ; dflags <- getDynFlags + ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) + ; traceTcS "solveSimpleWanteds end }" $ + vcat [ text "iterations =" <+> ppr n + , text "residual =" <+> ppr wc ] + ; return wc } + where + go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) + -- See Note [The solveSimpleWanteds loop] + go n limit wc + | n `intGtLimit` limit + = failTcS $ TcRnSimplifierTooManyIterations simples limit wc + | isEmptyBag (wc_simple wc) + = return (n,wc) + + | otherwise + = do { -- Solve + wc1 <- solve_simple_wanteds wc + + -- Run plugins + ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 + + ; if rerun_plugin + then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin) + ; go (n+1) limit wc2 } -- Loop + else return (n, wc2) } -- Done + + +solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints +-- 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, wc_errors = errs }) + = nestTcS $ + do { solveSimples simples1 + ; (implics2, unsolved) <- getUnsolvedInerts + ; return (WC { wc_simple = unsolved + , wc_impl = implics1 `unionBags` implics2 + , wc_errors = errs }) } + +{- Note [The solveSimpleWanteds loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a bunch of simple constraints is done in a loop, +(the 'go' loop of 'solveSimpleWanteds'): + 1. Try to solve them + 2. Try the plugin + 3. If the plugin wants to run again, go back to step 1 +-} + +{- +************************************************************************ +* * + Solving flat constraints: solveSimples +* * +********************************************************************* -} + +-- The main solver loop implements Note [Basic Simplifier Plan] +--------------------------------------------------------------- +solveSimples :: Cts -> TcS () +-- Returns the final InertSet in TcS +-- Has no effect on work-list or residual-implications +-- The constraints are initially examined in left-to-right order + +solveSimples cts + = {-# SCC "solveSimples" #-} + do { emitWork cts; solve_loop } + where + solve_loop + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem + ; case sel of + Nothing -> return () + Just ct -> do { solveOne ct + ; solve_loop } } + +solveOne :: Ct -> TcS () -- Solve one constraint +solveOne workItem + = do { wl <- getWorkList + ; inerts <- getInertSet + ; tclevel <- getTcLevel + ; traceTcS "----------------------------- " empty + ; traceTcS "Start solver pipeline {" $ + vcat [ text "tclevel =" <+> ppr tclevel + , text "work item =" <+> ppr workItem + , text "inerts =" <+> ppr inerts + , text "rest of worklist =" <+> ppr wl ] + + ; bumpStepCountTcS -- One step for each constraint processed + ; solve workItem } + where + solve :: Ct -> TcS () + solve ct + = do { traceTcS "solve {" (text "workitem = " <+> ppr ct) + ; res <- runSolverStage (solveCt ct) + ; traceTcS "end solve }" (ppr res) + ; case res of + StartAgain ct -> do { traceTcS "Go round again" (ppr ct) + ; solve ct } + + Stop ev s -> do { traceFireTcS ev s + ; traceTcS "End solver pipeline }" empty + ; return () } + + -- ContinueWith can't happen: res :: SolverStage Void + -- solveCt either solves the constraint, or puts + -- the unsolved constraint in the inert set. + } + +{- ********************************************************************* +* * +* Solving one constraint: solveCt +* * +************************************************************************ + +Note [Canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~ +Canonicalization converts a simple constraint to a canonical form. It is +unary (i.e. treats individual constraints one at a time). + +Constraints originating from user-written code come into being as +CNonCanonicals. We know nothing about these constraints. So, first: + + Classify CNonCanoncal constraints, depending on whether they + are equalities, class predicates, or other. + +Then proceed depending on the shape of the constraint. Generally speaking, +each constraint gets rewritten and then decomposed into one of several forms +(see type Ct in GHC.Tc.Types). + +When an already-canonicalized constraint gets kicked out of the inert set, +it must be recanonicalized. But we know a bit about its shape from the +last time through, so we can skip the classification step. +-} + +solveCt :: Ct -> SolverStage Void +-- The Void result tells us that solveCt cannot return +-- a ContinueWith; it must return Stop or StartAgain. +solveCt (CNonCanonical ev) = solveNC ev +solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev + +solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel + , eq_lhs = lhs, eq_rhs = rhs })) + = solveEquality ev eq_rel (canEqLHSType lhs) rhs + +solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) + = do { ev <- rewriteEvidence ev + -- It is (much) easier to rewrite and re-classify than to + -- rewrite the pieces and build a Reduction that will rewrite + -- the whole constraint + ; case classifyPredType (ctEvPred ev) of + ForAllPred tvs th p -> Stage $ solveForAll ev tvs th p pend_sc + _ -> pprPanic "SolveCt" (ppr ev) } + +solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc })) + = do { ev <- rewriteEvidence ev + -- It is easier to rewrite and re-classify than to rewrite + -- the pieces and build a Reduction that will rewrite the + -- whole constraint + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys + -> solveDict (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = pend_sc }) + _ -> pprPanic "solveCt" (ppr ev) } + +------------------ +solveNC :: CtEvidence -> SolverStage Void +solveNC ev + = -- Instead of rewriting the evidence before classifying, it's possible we + -- can make progress without the rewrite. Try this first. + -- For insolubles (all of which are equalities), do /not/ rewrite the arguments + -- In #14350 doing so led entire-unnecessary and ridiculously large + -- type function expansion. Instead, canEqNC just applies + -- the substitution to the predicate, and may do decomposition; + -- e.g. a ~ [a], where [G] a ~ [Int], can decompose + case classifyPredType (ctEvPred ev) of { + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ; + _ -> + + -- Do rewriting on the constraint, especially zonking + do { ev <- rewriteEvidence ev + ; let irred = IrredCt { ir_ev = ev, ir_reason = IrredShapeReason } + + -- And then re-classify + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> solveDictNC ev cls tys + ForAllPred tvs th p -> Stage $ solveForAllNC ev tvs th p + IrredPred {} -> solveIrred irred + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 + -- This case only happens if (say) `c` is unified with `a ~# b`, + -- but that is rare becuase it requires c :: CONSTRAINT UnliftedRep + + }} + + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +{- Note [Quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The -XQuantifiedConstraints extension allows type-class contexts like this: + + data Rose f x = Rose x (f (Rose f x)) + + instance (Eq a, forall b. Eq b => Eq (f b)) + => Eq (Rose f a) where + (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 + +Note the (forall b. Eq b => Eq (f b)) in the instance contexts. +This quantified constraint is needed to solve the + [W] (Eq (f (Rose f x))) +constraint which arises form the (==) definition. + +The wiki page is + https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints +which in turn contains a link to the GHC Proposal where the change +is specified, and a Haskell Symposium paper about it. + +We implement two main extensions to the design in the paper: + + 1. We allow a variable in the instance head, e.g. + f :: forall m a. (forall b. m b) => D (m a) + Notice the 'm' in the head of the quantified constraint, not + a class. + + 2. We support superclasses to quantified constraints. + For example (contrived): + f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool + f x y = x==y + Here we need (Eq (m a)); but the quantified constraint deals only + with Ord. But we can make it work by using its superclass. + +Here are the moving parts + * Language extension {-# LANGUAGE QuantifiedConstraints #-} + and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension + + * A new form of evidence, EvDFun, that is used to discharge + such wanted constraints + + * checkValidType gets some changes to accept forall-constraints + only in the right places. + + * Predicate.Pred gets a new constructor ForAllPred, and + and classifyPredType analyses a PredType to decompose + the new forall-constraints + + * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts, + which holds all the Given forall-constraints. In effect, + such Given constraints are like local instance decls. + + * When trying to solve a class constraint, via + GHC.Tc.Solver.Instance.Class.matchInstEnv, use the InstEnv from inert_insts + so that we include the local Given forall-constraints + in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.) + + * `solveForAll` deals with solving a forall-constraint. See + Note [Solving a Wanted forall-constraint] + + * We augment the kick-out code to kick out an inert + forall constraint if it can be rewritten by a new + type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable + +Note that a quantified constraint is never /inferred/ +(by GHC.Tc.Solver.simplifyInfer). A function can only have a +quantified constraint in its type if it is given an explicit +type signature. + +-} + +solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType + -> TcS (StopOrContinue Void) +-- NC: this came from CNonCanonical, so we have not yet expanded superclasses +-- Precondition: already rewritten by inert set +solveForAllNC ev tvs theta pred + | isGiven ev -- See Note [Eagerly expand given superclasses] + , Just (cls, tys) <- cls_pred_tys_maybe + = do { dflags <- getDynFlags + ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + ; emitWork (listToBag sc_cts) + ; solveForAll ev tvs theta pred doNotExpand } + -- doNotExpand: as we have already (eagerly) expanded superclasses for this class + + | otherwise + = do { dflags <- getDynFlags + ; let fuel | Just (cls, _) <- cls_pred_tys_maybe + , classHasSCs cls = qcsFuel dflags + -- See invariants (a) and (b) in QCI.qci_pend_sc + -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + -- See Note [Quantified constraints] + | otherwise = doNotExpand + ; solveForAll ev tvs theta pred fuel } + where + cls_pred_tys_maybe = getClassPredTys_maybe pred + +solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel + -> TcS (StopOrContinue Void) +-- Precondition: already rewritten by inert set +solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc }) + tvs theta pred _fuel + = -- See Note [Solving a Wanted forall-constraint] + setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ + -- This setSrcSpan is important: the emitImplicationTcS uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) + do { let empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs + is_qc = IsQC (ctLocOrigin loc) + + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + -- Very like the code in tcSkolDFunType + ; rec { skol_info <- mkSkolemInfo skol_info_anon + ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs + ; let inst_pred = substTy subst pred + inst_theta = substTheta subst theta + skol_info_anon = InstSkol is_qc (get_size inst_pred) } + + ; given_ev_vars <- mapM newEvVar inst_theta + ; (lvl, (w_id, wanteds)) + <- pushLevelNoWorkList (ppr skol_info) $ + do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) + -- Set the thing to prove to have a ScOrigin, so we are + -- careful about its termination checks. + -- See (QC-INV) in Note [Solving a Wanted forall-constraint] + ; wanted_ev <- newWantedEvVarNC loc' rewriters inst_pred + ; return ( ctEvEvId wanted_ev + , unitBag (mkNonCanonical wanted_ev)) } + + ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds + + ; setWantedEvTerm dest True $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = ev_binds, et_body = w_id } + + ; stopWith ev "Wanted forall-constraint" } + where + -- Getting the size of the head is a bit horrible + -- because of the special treament for class predicates + get_size pred = case classifyPredType pred of + ClassPred cls tys -> pSizeClassPred cls tys + _ -> pSizeType pred + + -- See Note [Solving a Given forall-constraint] +solveForAll ev@(CtGiven {}) tvs _theta pred fuel + = do { addInertForAll qci + ; stopWith ev "Given forall-constraint" } + where + qci = QCI { qci_ev = ev, qci_tvs = tvs + , qci_pred = pred, qci_pend_sc = fuel } + +{- Note [Solving a Wanted forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a wanted forall (quantified) constraint + [W] df :: forall ab. (Eq a, Ord b) => C x a b +is delightfully easy. Just build an implication constraint + forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a +and discharge df thus: + df = /\ab. \g1 g2. let in d +where is filled in by solving the implication constraint. +All the machinery is to hand; there is little to do. + +The tricky point is about termination: see #19690. We want to maintain +the invariant (QC-INV): + + (QC-INV) Every quantified constraint returns a non-bottom dictionary + +just as every top-level instance declaration guarantees to return a non-bottom +dictionary. But as #19690 shows, it is possible to get a bottom dicionary +by superclass selection if we aren't careful. The situation is very similar +to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; +and we use the same solution: + +* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) +* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) + +Both of these things are done in solveForAll. Now the mechanism described +in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. + +Note [Solving a Given forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a Given constraint + [G] df :: forall ab. (Eq a, Ord b) => C x a b +we just add it to TcS's local InstEnv of known instances, +via addInertForall. Then, if we look up (C x Int Bool), say, +we'll find a match in the InstEnv. + + +************************************************************************ +* * + Evidence transformation +* * +************************************************************************ +-} + +rewriteEvidence :: CtEvidence -> SolverStage CtEvidence +-- (rewriteEvidence old_ev new_pred co do_next) +-- Main purpose: create new evidence for new_pred; +-- unless new_pred is cached already +-- * Calls do_next with (new_ev :: new_pred), with same wanted/given flag as old_ev +-- * If old_ev was wanted, create a binding for old_ev, in terms of new_ev +-- * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev +-- * Stops if new_ev is already cached +-- +-- Old evidence New predicate is Return new evidence +-- flavour of same flavor +-- ------------------------------------------------------------------- +-- Wanted Already solved or in inert Stop +-- Not do_next new_evidence +-- +-- Given Already in inert Stop +-- Not do_next new_evidence + +{- Note [Rewriting with Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the coercion is just reflexivity then you may re-use the same +evidence variable. But be careful! Although the coercion is Refl, new_pred +may reflect the result of unification alpha := ty, so new_pred might +not _look_ the same as old_pred, and it's vital to proceed from now on +using new_pred. + +The rewriter preserves type synonyms, so they should appear in new_pred +as well as in old_pred; that is important for good error messages. + +If we are rewriting with Refl, then there are no new rewriters to add to +the rewriter set. We check this with an assertion. + -} + + +rewriteEvidence ev + = Stage $ do { traceTcS "rewriteEvidence" (ppr ev) + ; (redn, rewriters) <- rewrite ev (ctEvPred ev) + ; finish_rewrite ev redn rewriters } + +finish_rewrite :: CtEvidence -- ^ old evidence + -> Reduction -- ^ new predicate + coercion, of type ~ new predicate + -> RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Types.Constraint + -> TcS (StopOrContinue CtEvidence) +finish_rewrite old_ev (Reduction co new_pred) rewriters + | isReflCo co -- See Note [Rewriting with Refl] + = assert (isEmptyRewriterSet rewriters) $ + continueWith (setCtEvPredType old_ev new_pred) + +finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) + (Reduction co new_pred) rewriters + = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted + do { new_ev <- newGivenEvVar loc (new_pred, new_tm) + ; continueWith new_ev } + where + -- mkEvCast optimises ReflCo + new_tm = mkEvCast (evId old_evar) + (downgradeRole Representational (ctEvRole ev) co) + +finish_rewrite ev@(CtWanted { ctev_dest = dest + , ctev_loc = loc + , ctev_rewriters = rewriters }) + (Reduction co new_pred) new_rewriters + = do { mb_new_ev <- newWanted loc rewriters' new_pred + ; massert (coercionRole co == ctEvRole ev) + ; setWantedEvTerm dest True $ + mkEvCast (getEvExpr mb_new_ev) + (downgradeRole Representational (ctEvRole ev) (mkSymCo co)) + ; case mb_new_ev of + Fresh new_ev -> continueWith new_ev + Cached _ -> stopWith ev "Cached wanted" } + where + rewriters' = rewriters S.<> new_rewriters + +{- ******************************************************************* +* * +* Typechecker plugins +* * +******************************************************************* -} + +-- | Extract the (inert) givens and invoke the plugins on them. +-- Remove solved givens from the inert set and emit insolubles, but +-- return new work produced so that 'solveSimpleGivens' can feed it back +-- into the main solver. +runTcPluginsGiven :: TcS [Ct] +runTcPluginsGiven + = do { solvers <- getTcPluginSolvers + ; if null solvers then return [] else + do { givens <- getInertGivens + ; if null givens then return [] else + do { traceTcS "runTcPluginsGiven {" (ppr givens) + ; p <- runTcPluginSolvers solvers (givens,[]) + ; let (solved_givens, _) = pluginSolvedCts p + insols = map (ctIrredCt PluginReason) (pluginBadCts p) + ; updInertCans (removeInertCts solved_givens . + updIrreds (addIrreds insols) ) + ; traceTcS "runTcPluginsGiven }" $ + vcat [ text "solved_givens:" <+> ppr solved_givens + , text "insols:" <+> ppr insols + , text "new:" <+> ppr (pluginNewCts p) ] + ; return (pluginNewCts p) } } } + +-- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on +-- them and produce an updated bag of wanteds (possibly with some new +-- work) and a bag of insolubles. The boolean indicates whether +-- 'solveSimpleWanteds' should feed the updated wanteds back into the +-- main solver. +runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) +runTcPluginsWanted wc@(WC { wc_simple = simples1 }) + | isEmptyBag simples1 + = return (False, wc) + | otherwise + = do { solvers <- getTcPluginSolvers + ; if null solvers then return (False, wc) else + + do { given <- getInertGivens + ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs + + ; traceTcS "Running plugins (" (vcat [ text "Given:" <+> ppr given + , text "Watned:" <+> ppr wanted ]) + ; p <- runTcPluginSolvers solvers (given, bagToList wanted) + ; let (_, solved_wanted) = pluginSolvedCts p + (_, unsolved_wanted) = pluginInputCts p + new_wanted = pluginNewCts p + insols = pluginBadCts p + all_new_wanted = listToBag new_wanted `andCts` + listToBag unsolved_wanted `andCts` + listToBag insols + +-- SLPJ: I'm deeply suspicious of this +-- ; updInertCans (removeInertCts $ solved_givens) + + ; mapM_ setEv solved_wanted + + ; traceTcS "Finished plugins }" (ppr new_wanted) + ; return ( notNull (pluginNewCts p) + , wc { wc_simple = all_new_wanted } ) } } + where + setEv :: (EvTerm,Ct) -> TcS () + setEv (ev,ct) = case ctEvidence ct of + CtWanted { ctev_dest = dest } -> setWantedEvTerm dest True ev -- TODO: plugins should be able to signal non-canonicity + _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" + +-- | A pair of (given, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct]) + +-- | A solved pair of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [(EvTerm,Ct)]) + +-- | Represents collections of constraints generated by typechecker +-- plugins +data TcPluginProgress = TcPluginProgress + { pluginInputCts :: SplitCts + -- ^ Original inputs to the plugins with solved/bad constraints + -- removed, but otherwise unmodified + , pluginSolvedCts :: SolvedCts + -- ^ Constraints solved by plugins + , pluginBadCts :: [Ct] + -- ^ Constraints reported as insoluble by plugins + , pluginNewCts :: [Ct] + -- ^ New constraints emitted by plugins + } + +getTcPluginSolvers :: TcS [TcPluginSolver] +getTcPluginSolvers + = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } + +-- | Starting from a pair of (given, wanted) constraints, +-- invoke each of the typechecker constraint-solving plugins in turn and return +-- +-- * the remaining unmodified constraints, +-- * constraints that have been solved, +-- * constraints that are insoluble, and +-- * new work. +-- +-- Note that new work generated by one plugin will not be seen by +-- other plugins on this pass (but the main constraint solver will be +-- re-invoked and they will see it later). There is no check that new +-- work differs from the original constraints supplied to the plugin: +-- the plugin itself should perform this check if necessary. +runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress +runTcPluginSolvers solvers all_cts + = do { ev_binds_var <- getTcEvBindsVar + ; foldM (do_plugin ev_binds_var) initialProgress solvers } + where + do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin ev_binds_var p solver = do + result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p)) + return $ progress p result + + progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress + progress p + (TcPluginSolveResult + { tcPluginInsolubleCts = bad_cts + , tcPluginSolvedCts = solved_cts + , tcPluginNewCts = new_cts + } + ) = + p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p) + , pluginSolvedCts = add solved_cts (pluginSolvedCts p) + , pluginNewCts = new_cts ++ pluginNewCts p + , pluginBadCts = bad_cts ++ pluginBadCts p + } + + initialProgress = TcPluginProgress all_cts ([], []) [] [] + + discard :: [Ct] -> SplitCts -> SplitCts + discard cts (xs, ys) = + (xs `without` cts, ys `without` cts) + + without :: [Ct] -> [Ct] -> [Ct] + without = deleteFirstsBy eq_ct + + eq_ct :: Ct -> Ct -> Bool + eq_ct c c' = ctFlavour c == ctFlavour c' + && ctPred c `tcEqType` ctPred c' + + add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts + add xs scs = foldl' addOne scs xs + + addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts + addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, wanteds) + CtWanted {} -> (givens, (ev,ct):wanteds) + + 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,19 +23,18 @@ tcFamTyPats, tcTyFamInstEqn, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily, checkFamTelescope + checkFamTelescope ) where import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config.HsToCore import GHC.Hs -import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) - , mkTcRnUnknownMessage, IllegalNewtypeReason (..) ) +import GHC.Tc.Errors.Types import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -44,7 +43,8 @@ import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint ) import GHC.Tc.Types.Constraint( emptyWC ) import GHC.Tc.Validity -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType import GHC.Tc.TyCl.Utils import GHC.Tc.TyCl.Class import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) @@ -55,13 +55,14 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) import GHC.Rename.Env( lookupConstructorFields ) import GHC.Core.Multiplicity -import GHC.Core.FamInstEnv +import GHC.Core.FamInstEnv ( mkBranchedCoAxiom, mkCoAxBranch ) import GHC.Core.Coercion import GHC.Core.Type import GHC.Core.TyCo.Rep -- for checkValidRoles @@ -243,7 +244,13 @@ = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class -- See Note [Kind checking for type and class decls] - (tc_tycons, kindless) <- kcTyClGroup kisig_env tyclds + (tc_tycons, kindless) <- checkNoErrs $ + kcTyClGroup kisig_env tyclds + -- checkNoErrs: If the TyCons are ill-kinded, stop now. Else we + -- can get follow-on errors. Example: #23252, where the TyCon + -- had an ill-scoped kind forall (d::k) k (a::k). blah + -- and that ill-scoped kind made role inference fall over. + ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) -- Step 2: type-check all groups together, returning @@ -347,6 +354,268 @@ you can always specify a CUSK directly to make this work out. See tc269 for an example. +Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TcTyCon is one of the variants of TyCon. First, here are its invariants: + +* TcTyCon: a TyCon built with the TcTyCon constructor + A TcTyCon contains TcTyVars in its binders and kind + +* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar) + +* MonoTcTyCon: a form of TcTyCon + - Flag tcTyConIsPoly = False + + - tyConBinders are TcTyConBinders: they contain TcTyVars, which are + unification variables (TyVarTv), and whose kinds may contain + unification variables. + + - tyConKind: the Monomorphic Recursion Principle: + a MonoTcTyCon has a /monomorphic kind/. + See Note [No polymorphic recursion in type decls]. + But the tyConKind may contain free unification variables. + + - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable + The order matters: Specified then Required variables. + E.g. in + data T a (b :: k) = ... + the order will be [k, a, b]. + + We do not allow @k-binders in inference mode, so we do not need to worry about + data T a @k (b :: k) = ... + where we would have to put `k` (Specified) after `a` (Required) + + NB: There are no Inferred binders in tyConScopedTyVars; 'a' may + also be poly-kinded, but that kind variable will be added by + generaliseTcTyCon, in the passage to a PolyTcTyCon. + + - tyConBinders are irrelevant; we just use tcTyConScopedTyVars + Well not /quite/ irrelevant: + * its length gives the number of explicit binders, and so allows us to + distinguish between the implicit and explicit elements of + tyConScopedTyVars. + * at construction time (mkTcTyCon) for a MonoTcTyCon (the call to mkTcTyCon + in GHC.Tc.Gen.HsType.kcInferDeclHeader) the tyConBinders are used to + construct the tyConKind; all must have AnonTCB visiblity so we we get + a monokind. + +* PolyTcTyCon: a form of TcTyCon + - Flag tcTyConIsPoly = True; this is used only to short-cut zonking + + - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, + with fixed kinds, and accurate skolem info: no unification variables here + + tyConBinders includes the Inferred binders if any + + tyConBinders uses the Names from the original, renamed program. + + - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders) + All the types have been swizzled back to use the original Names + See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon + +The main purpose of these TcTyCons is during kind-checking of +type/class declarations (in GHC.Tc.TyCl). During kind checking we +come upon knowledge of the eventual tycon in bits and pieces, and we +use a TcTyCon to record what we know before we are ready to build the +final TyCon. Here is the plan: + +* Step 1 (inferInitialKinds, called from kcTyClGroup + inference only, skipped for checking): + Make a MonoTcTyCon whose binders are TcTyVars, + that may contain free unification variables. + See Note [No polymorphic recursion in type decls] + +* Step 2 (kcTyClDecl, called from kcTyClGroup) + Kind-check the declarations of the group; this step just does + unifications that affect the unification variables created in + Step 1 + +* Step 3 (generaliseTcTyCon, called from kcTyClGroup) + Generalise that MonoTcTyCon to make a PolyTcTyCon + Its binders are skolem TcTyVars, with accurate SkolemInfo + +* Step 4 (tcTyClDecl, called from tcTyClDecls) + Typecheck the type and class decls to produce a final TyCon + Its binders are final TyVars, not TcTyVars + +Note that a MonoTcTyCon can contain unification variables, but a +PolyTcTyCon does not: only skolem TcTyVars. See the invariants above. + +More details about /kind inference/: + +S1) In kcTyClGroup, we use inferInitialKinds to look over the + declaration of any TyCon that lacks a kind signature or + CUSK, to determine its "shape"; for example, the number of + parameters, and any kind signatures. + + We record that shape record that shape in a MonoTcTyCon; it is + "mono" because it has not been been generalised, and its binders + and result kind may have free unification variables. + +S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the + body (class methods, data constructors, etc.) of each of + these MonoTcTyCons, which has the effect of filling in the + metavariables in the tycon's initial kind. + +S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize + each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it, + and a final, fixed kind. + +S4) Finally, back in tcTyClDecls, we extend the environment with + the PolyTcTyCons, and typecheck each declaration (regardless + of kind signatures etc) to get final TyCon. + +More details about /kind checking/ + +S5) In kcTyClGroup, we use checkInitialKinds to get the + utterly-final Kind of all TyCons in the group that + (a) have a standalone kind signature or + (b) have a CUSK. + This produces a PolyTcTyCon, that is, a TcTyCon in which the binders + and result kind are full of TyVars (not TcTyVars). No unification + variables here; everything is in its final form. + +Wrinkles: + +(W1) When recovering from a type error in a type declaration, + we want to put the erroneous TyCon in the environment in a + way that won't lead to more errors. We use a PolyTcTyCon for this; + see makeRecoveryTyCon. + +(W2) tyConScopedTyVars. A challenging piece in all of this is that we + end up taking three separate passes over every declaration: + - one in inferInitialKind (this pass look only at the head, not the body) + - one in kcTyClDecls (to kind-check the body) + - a final one in tcTyClDecls (to desugar) + + In the latter two passes, we need to connect the user-written type + variables in an LHsQTyVars with the variables in the tycon's + inferred kind. Because the tycon might not have a CUSK, this + matching up is, in general, quite hard to do. (Look through the + git history between Dec 2015 and Apr 2016 for + GHC.Tc.Gen.HsType.splitTelescopeTvs!) + + Instead of trying, we just store the list of type variables to + bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. + These tyvars are brought into scope by the calls to + tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) + in kcTyClDecl. + + In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather + than just [TcTyVar]? Consider these mutually-recursive decls + data T (a :: k1) b = MkT (S a b) + data S (c :: k2) d = MkS (T c d) + We start with k1 bound to kappa1, and k2 to kappa2; so initially + in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But + then kappa1 and kappa2 get unified; so after the zonking in + 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. + +See also Note [Type checking recursive type and class declarations]. + +Note [No polymorphic recursion in type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Tc.HsType.kcInferDeclHeader we use mkAnonTyConBinders to make +the TyConBinders for the MonoTcTyCon. Here is why. + +Should this kind-check (cf #16344)? + data T ka (a::ka) b = MkT (T Type Int Bool) + (T (Type -> Type) Maybe Bool) + +Notice that T is used at two different kinds in its RHS. No! +This should not kind-check. Polymorphic recursion is known to +be a tough nut. + +Many moons ago, we laboriously (with help from the renamer) tried to give T +the polymorphic kind + T :: forall ka -> ka -> kappa -> Type +where kappa is a unification variable, even in the inferInitialKinds phase +(which is what kcInferDeclHeader is all about). But that is dangerously +fragile (see #16344), because `kappa` might get unified with `ka`, and +depending on just /when/ that unification happens, the instantiation of T's +kind would vary between different call sites of T. + +We encountered similar trickiness with invisible binders in type +declarations: see Note [No inference for invisible binders in type decls] + +Solution: the Monomorphic Recursion Principle: + + A MonoTcTyCon has a monomoprhic kind (no foralls!) + +See the invariants on MonoTcTyCon in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]. + +So kcInferDeclHeader gives T a straightforward monomorphic kind, with no +quantification whatsoever. That's why we always use mkAnonTyConBinder for +all arguments when figuring out tc_binders. + +But notice that (#16344 comment:3) + +* Consider this declaration: + data T2 ka (a::ka) = MkT2 (T2 Type a) + + Starting with inferInitialKinds + (Step 1 of Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]): + MonoTcTyCon binders: + ka[tyv] :: (kappa1[tau] :: Type) + a[tyv] :: (ka[tyv] :: Type) + MonoTcTyCon kind: + T2 :: kappa1[tau] -> ka[tyv] -> Type + + Given this kind for T2, in Step 2 we kind-check (T2 Type a) + from where we see + T2's first arg: (kappa1 ~ Type) + T2's second arg: (ka ~ ka) + These constraints are soluble by (kappa1 := Type) + so generaliseTcTyCon (Step 3) gives + T2 :: forall (k::Type) -> k -> * + + But now the /typechecking/ (Step 4, aka desugaring, tcTyClDecl) + phase fails, because the call (T2 Type a) in the RHS is ill-kinded. + + We'd really prefer all errors to show up in the kind checking phase. + +* This algorithm still accepts (in all phases) + data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) + although T3 is really polymorphic-recursive too. + Perhaps we should somehow reject that. + +Note [No inference for invisible binders in type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#22560): + data T @k (a::k) = MkT (...(T ty)...) +What monokind can we give to T after step 1 of the kind inference +algorithm described in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]? +Remember: Step 1 generates a MonoTcTyCon. + +It can't be + T :: kappa1 -> kappa2 -> Type +because the invocation `(T ty)` doesn't have a visible argument for `kappa`. +Nor can it be + T :: forall k. kappa2 -> Type +because that breaks the Monomorphic Recursion Principle: MonoTcTyCons have +monomorphic kinds; see Note [No polymorphic recursion in type decls]. It could be + T :: kappa1 ->. kappa2 -> type +where `->.` is a new kind of arrow in kinds, which (like a type-class argument +in terms) is invisibly instantiated. Or we could fake it with + T :: forall _. kappa2 -> Type +where `_` is a completely fresh variable, but that seems very smelly and makes it +harder to talk about the Monomorphic Recursion Principle. Moreover we'd need +some extra fancy types in TyConBinders to record this extra information. + +Note that in *terms* we do not allow + f @a (x::a) = rhs +unless `f` has a type signature. So we do the same for types: + + We allow `@` binders in data type declarations ONLY if the + type constructor has a standalone kind signature (or a CUSK). + +That means that GHC.Tc.Gen.HsType.kcInferDeclHeader, which is used when we +don't have a kind signature or CUSK, and builds a MonoTcTyCon, we can simply +reject invisible binders outright (GHC.Tc.Gen.HsType.rejectInvisibleBinders); +and continue to use mkAnonTyConBinders as described in +Note [No polymorphic recursion in type decls]. + +If we get cries of pain we can revist this decision. + Note [CUSKs and PolyKinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -398,100 +667,6 @@ See also Note [Kind checking recursive type and class declarations] -Note [How TcTyCons work] -~~~~~~~~~~~~~~~~~~~~~~~~ -TcTyCons are used for two distinct purposes - -1. When recovering from a type error in a type declaration, - we want to put the erroneous TyCon in the environment in a - way that won't lead to more errors. We use a TcTyCon for this; - see makeRecoveryTyCon. - -2. When checking a type/class declaration (in module GHC.Tc.TyCl), we come - upon knowledge of the eventual tycon in bits and pieces, and we use - a TcTyCon to record what we know before we are ready to build the - final TyCon. Here is the plan: - - Step 1 (inferInitialKinds, inference only, skipped for checking): - Make a MonoTcTyCon whose binders are TcTyVars, - which may contain free unification variables - - Step 2 (generaliseTcTyCon) - Generalise that MonoTcTyCon to make a PolyTcTyCon - Its binders are skolem TcTyVars, with accurate SkolemInfo - - Step 3 (tcTyClDecl) - Typecheck the type and class decls to produce a final TyCon - Its binders are final TyVars, not TcTyVars - - Note that a MonoTcTyCon can contain unification variables, - but a PolyTcTyCon does not: only skolem TcTyVars. See - Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType - - More details about /kind inference/: - - S1) In kcTyClGroup, we use inferInitialKinds to look over the - declaration of any TyCon that lacks a kind signature or - CUSK, to determine its "shape"; for example, the number of - parameters, and any kind signatures. - - We record that shape record that shape in a MonoTcTyCon; it is - "mono" because it has not been been generalised, and its binders - and result kind may have free unification variables. - - S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the - body (class methods, data constructors, etc.) of each of - these MonoTcTyCons, which has the effect of filling in the - metavariables in the tycon's initial kind. - - S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize - each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it, - and a final, fixed kind. - - S4) Finally, back in TcTyClDecls, we extend the environment with - the PolyTcTyCons, and typecheck each declaration (regardless - of kind signatures etc) to get final TyCon. - - More details about /kind checking/ - - S5) In kcTyClGroup, we use checkInitialKinds to get the - utterly-final Kind of all TyCons in the group that - (a) have a separate kind signature or - (b) have a CUSK. - This produces a PolyTcTyCon, that is, a TcTyCon in which the binders - and result kind are full of TyVars (not TcTyVars). No unification - variables here; everything is in its final form. - -3. tyConScopedTyVars. A challenging piece in all of this is that we - end up taking three separate passes over every declaration: - - one in inferInitialKind (this pass look only at the head, not the body) - - one in kcTyClDecls (to kind-check the body) - - a final one in tcTyClDecls (to desugar) - - In the latter two passes, we need to connect the user-written type - variables in an LHsQTyVars with the variables in the tycon's - inferred kind. Because the tycon might not have a CUSK, this - matching up is, in general, quite hard to do. (Look through the - git history between Dec 2015 and Apr 2016 for - GHC.Tc.Gen.HsType.splitTelescopeTvs!) - - Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. - These tyvars are brought into scope by the calls to - tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) - in kcTyClDecl. - - In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather - than just [TcTyVar]? Consider these mutually-recursive decls - data T (a :: k1) b = MkT (S a b) - data S (c :: k2) d = MkS (T c d) - We start with k1 bound to kappa1, and k2 to kappa2; so initially - in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But - then kappa1 and kappa2 get unified; so after the zonking in - 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. - -See also Note [Type checking recursive type and class declarations]. - Note [Swizzling the tyvars before generaliseTcTyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This Note only applies when /inferring/ the kind of a TyCon. @@ -766,15 +941,16 @@ = do { let names_in_this_decl :: [Name] names_in_this_decl = tycld_names decl - -- Extract the specified/required binders and skolemise them - ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl + ; tc_infos <- liftZonkM $ + do { -- Extract the specified/required binders and skolemise them + ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl - -- Zonk, to manifest the side-effects of skolemisation to the swizzler - -- NB: it's important to skolemise them all before this step. E.g. - -- class C f where { type T (f :: k) } - -- We only skolemise k when looking at T's binders, - -- but k appears in f's kind in C's binders. - ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs + -- Zonk, to manifest the side-effects of skolemisation to the swizzler + -- NB: it's important to skolemise them all before this step. E.g. + -- class C f where { type T (f :: k) } + -- We only skolemise k when looking at T's binders, + -- but k appears in f's kind in C's binders. + ; mapM zonk_tc_tycon tc_with_tvs } -- Swizzle ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) @@ -789,7 +965,7 @@ at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats at_names _ = [] -- Only class decls have associated types - skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, ScopedPairs) + skolemise_tc_tycon :: Name -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs) -- Zonk and skolemise the Specified and Required binders skolemise_tc_tycon tc_name = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name @@ -799,7 +975,7 @@ ; return (tc, skol_info, scoped_prs) } zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs) - -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) + -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) zonk_tc_tycon (tc, skol_info, scoped_prs) = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs -- We really have to do this again, even though @@ -864,8 +1040,13 @@ swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) - swizzle_bndr _ tcv _ - = return ((), swizzle_var tcv) + swizzle_bndr :: () + -> TyCoVar + -> ForAllTyFlag + -> (() -> TyCoVar -> Identity r) + -> Identity r + swizzle_bndr _ tcv _ k + = k () (swizzle_var tcv) swizzle_var :: Var -> Var swizzle_var v @@ -913,10 +1094,12 @@ , text "inferred =" <+> pprTyVars inferred ]) -- Step 3: Final zonk: quantifyTyVars may have done some defaulting - ; inferred <- zonkTcTyVarsToTcTyVars inferred - ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs - ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs - ; tc_res_kind <- zonkTcType tc_res_kind + ; (inferred, sorted_spec_tvs,req_tvs,tc_res_kind) <- liftZonkM $ + do { inferred <- zonkTcTyVarsToTcTyVars inferred + ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs + ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs + ; tc_res_kind <- zonkTcType tc_res_kind + ; return (inferred, sorted_spec_tvs, req_tvs, tc_res_kind) } ; traceTc "generaliseTcTyCon: post zonk" $ vcat [ text "tycon =" <+> ppr tc @@ -1090,7 +1273,7 @@ Note [Inferring kinds for type declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This note deals with /inference/ for type declarations -that do not have a CUSK. Consider +that do not have a CUSK or a SAKS. Consider data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) @@ -1254,18 +1437,17 @@ specifically, so we just include a note to users whenever we infer VDQ. The testsuite did not show up a single spurious inclusion of this message. -The context is added in addVDQNote, which looks for a visible TyConBinder -that also appears in the TyCon's kind. (I first looked at the kind for -a visible, dependent quantifier, but Note [No polymorphic recursion] in -GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in kcTyClDecl, -which is used only when inferring the kind of a tycon (never with a CUSK or -SAK). +The context is added in addVDQNote, which looks for a visible +TyConBinder that also appears in the TyCon's kind. (I first looked at +the kind for a visible, dependent quantifier, but + Note [No polymorphic recursion in type decls] +in GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in +kcTyClDecl, which is used only when inferring the kind of a tycon +(never with a CUSK or SAKS). Once upon a time, I (Richard E) thought that the tycon-kind could not be a forall-type. But this is wrong: data T :: forall k. k -> Type (with -XNoCUSKs) could end up here. And this is all OK. - - -} -------------- @@ -1389,7 +1571,7 @@ , fdTyVars = ktvs , fdResultSig = unLoc -> resultSig , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info + = do { let flav = familyInfoTyConFlavour Nothing info ctxt = TyFamResKindCtxt name ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ case famResultKindSignature resultSig of @@ -1430,7 +1612,7 @@ -- by default | otherwise -> return AnyKind where - flav = getFamFlav mb_parent_tycon info + flav = familyInfoTyConFlavour mb_parent_tycon info ctxt = TyFamResKindCtxt name -- See Note [Standalone kind signatures for associated types] @@ -1450,7 +1632,7 @@ Nothing -> return (TheKind liftedTypeKind) where ctxt = TyFamResKindCtxt name - flav = getFamFlav (Just cls) info + flav = familyInfoTyConFlavour (Just cls) info {- Note [Standalone kind signatures for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1535,29 +1717,6 @@ -} ---------------------------------- -getFamFlav - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyInfo pass - -> TyConFlavour -getFamFlav mb_parent_tycon info = - case info of - DataFamily -> DataFamilyFlavour mb_parent_tycon - OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon - ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon] - ClosedTypeFamilyFlavour - -{- Note [Closed type family mb_parent_tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's no way to write a closed type family inside a class declaration: - - class C a where - type family F a where -- error: parse error on input ‘where’ - -In fact, it is not clear what the meaning of such a declaration would be. -Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. --} - ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] @@ -1583,7 +1742,7 @@ -- TcTyVars rather than create skolemised variables for the bound variables. -- - inferInitialKinds makes the TcTyCon where the tyvars are TcTyVars -- - In this function, those TcTyVars are unified with other kind variables during --- kind inference (see [How TcTyCons work]) +-- kind inference (see GHC.Tc.TyCl Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]) kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) tycon = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ @@ -1848,7 +2007,7 @@ * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the fully-known, not knot-tied TcTyCon for T. - * Then, in GHC.Tc.Utils.Zonk.zonkTcTypeToType (and zonkTcTyCon in particular) + * Then, in GHC.Tc.Zonk.Type.zonkTcTypeToType (and zonkTcTyCon in particular) we look in the *global* env to get the TyCon. This fancy footwork (with two bindings for T) is only necessary for the @@ -2455,22 +2614,21 @@ -- class (forall a. a b ~ a c) => C b c -- The kind of `a` is unconstrained. ; dvs <- candidateQTyVarsOfTypes ctxt - ; let mk_doc tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt - ; return ( tidy_env2 - , sep [ text "the class context:" - , pprTheta ctxt ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; let err_ctx tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt + ; return (tidy_env2, UninfTyCtx_ClassContext ctxt) } + ; doNotQuantifyTyVars dvs err_ctx -- The pushLevelAndSolveEqualities will report errors for any -- unsolved equalities, so these zonks should not encounter -- any unfilled coercion variables unless there is such an error -- The zonk also squeeze out the TcTyCons, and converts -- Skolems to tyvars. - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs -- From TcTyVars to TyVars - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff - -- ToDo: do we need to zonk at_stuff? + ; (bndrs, ctxt, sig_stuff) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { ctxt <- zonkTcTypesToTypesX ctxt + ; sig_stuff <- mapM zonkTcMethInfoToMethInfoX sig_stuff + -- ToDo: do we need to zonk at_stuff? + ; return (bndrs, ctxt, sig_stuff) } -- TODO: Allow us to distinguish between abstract class, -- and concrete class with no methods (maybe by @@ -2526,7 +2684,10 @@ -> TcM [ClassATItem] tcClassATs class_name cls ats at_defs = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (TcRnBadAssociatedType class_name n) + sequence_ [ failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance $ InvalidAssoc + $ InvalidAssocDefault + $ AssocDefaultNotAssoc class_name n | n <- map at_def_tycon at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } @@ -2560,9 +2721,9 @@ = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ - text "More than one default declaration for" - <+> ppr (tyFamInstDeclName (unLoc d1))) + = failWithTc $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault $ + AssocMultipleDefaults (tyFamInstDeclName (unLoc d1)) tcDefaultAssocDecl fam_tc [L loc (TyFamInstDecl { tfid_eqn = @@ -2580,11 +2741,14 @@ -- Kind of family check ; assert (fam_tc_name == tc_name) $ - checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + checkTc (isTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc -- Arity check - ; checkTc (vis_pats == vis_arity) - (wrongNumberOfParmsErr vis_arity) + ; checkTc (vis_pats == vis_arity) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyArityMismatch fam_tc vis_arity -- Typecheck RHS -- @@ -2846,12 +3010,12 @@ = setSrcSpanA loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags + -- Fail eagerly to avoid reporting injectivity errors when + -- TypeFamilyDependencies is not enabled. ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal injectivity annotation" $$ - text "Use TypeFamilyDependencies to allow this") + TcRnTyFamDepsDisabled ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds + ; inj_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars closeOverKinds (mkVarSet inj_tvs) ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs @@ -2864,7 +3028,7 @@ tcTySynRhs roles_info tc_name hs_ty = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> do { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; traceTc "tc-syn" (ppr tc_name $$ ppr (getLclEnvRdrEnv env)) ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $ tcCheckLHsType hs_ty (TheKind res_kind) @@ -2873,15 +3037,14 @@ -- type T = forall a. Proxy a -- The kind of `a` is unconstrained. ; dvs <- candidateQTyVarsOfType rhs_ty - ; let mk_doc tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty - ; return ( tidy_env2 - , sep [ text "the type synonym right-hand side:" - , ppr rhs_ty ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; let err_ctx tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return (tidy_env2, UninfTyCtx_TySynRhs rhs_ty) } + ; doNotQuantifyTyVars dvs err_ctx - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; (bndrs, rhs_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { rhs_ty <- zonkTcTypeToTypeX rhs_ty + ; return (bndrs, rhs_ty) } ; let roles = roles_info tc_name ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) } where @@ -2918,22 +3081,24 @@ -- data (forall a. a b ~ a c) => T b c -- The kind of 'a' is unconstrained. ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta - ; return ( tidy_env2 - , sep [ text "the datatype context:" - , pprTheta theta ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; return (tidy_env2, UninfTyCtx_DataContext theta) } + ; doNotQuantifyTyVars dvs err_ctx -- Check that we don't use kind signatures without the extension ; kind_signatures <- xoptM LangExt.KindSignatures - ; when (isJust mb_ksig) $ - checkTc (kind_signatures) (badSigTyDecl tc_name) + ; case mb_ksig of + Just (L _ ksig) + | not kind_signatures + -> addErrTc $ TcRnKindSignaturesDisabled (Right (tc_name, ksig)) + _ -> return () - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta - ; res_kind <- zonkTcTypeToTypeX ze res_kind + ; (bndrs, stupid_theta, res_kind) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { stupid_theta <- zonkTcTypesToTypesX stupid_tc_theta + ; res_kind <- zonkTcTypeToTypeX res_kind + ; return (bndrs, stupid_theta, res_kind) } ; tycon <- fixM $ \ rec_tycon -> do { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons @@ -3045,14 +3210,15 @@ (map (const Nominal) qtvs) (locA loc)) } -checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM () +checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM () checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = do { -- Ensure that each equation's type constructor is for the right -- type family. E.g. barf on -- type family F a where { G Int = Bool } let tc_fam_tc_name = getName tc_fam_tc ; checkTc (tc_fam_tc_name == eqn_tc_name) $ - wrongTyFamName tc_fam_tc_name eqn_tc_name + TcRnIllegalInstance $ IllegalFamilyInstance $ + TyFamNameMismatch tc_fam_tc_name eqn_tc_name -- Check the arity of visible arguments -- If we wait until validity checking, we'll get kind errors @@ -3060,7 +3226,8 @@ ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc) vis_pats = numVisibleArgs hs_pats ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyArityMismatch tc_fam_tc vis_arity } {- Note [Instantiating a family tycon] @@ -3178,17 +3345,16 @@ -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType -- Example: typecheck/should_fail/T17301 ; dvs_rhs <- candidateQTyVarsOfType rhs_ty - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty - ; return ( tidy_env2 - , sep [ text "type family equation right-hand side:" - , ppr rhs_ty ] ) } - ; doNotQuantifyTyVars dvs_rhs mk_doc + ; return (tidy_env2, UninfTyCtx_TyFamRhs rhs_ty) } + ; doNotQuantifyTyVars dvs_rhs err_ctx - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, final_tvs) <- zonkTyBndrsX ze final_tvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; (final_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyBndrsX final_tvs) $ \ final_tvs -> + do { lhs_ty <- zonkTcTypeToTypeX lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX rhs_ty + ; return (final_tvs, lhs_ty, rhs_ty) } ; let pats = unravelFamInstPats lhs_ty -- Note that we do this after solveEqualities @@ -3336,18 +3502,19 @@ -- Check that we don't use GADT syntax in H98 world ; gadtSyntax_ok <- xoptM LangExt.GADTSyntax ; let gadt_syntax = anyLConIsGadt cons - ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) + ; unless (gadtSyntax_ok || not gadt_syntax) $ + addErrTc (TcRnGADTsDisabled tc_name) -- Check that the stupid theta is empty for a GADT-style declaration. -- See Note [The stupid context] in GHC.Core.DataCon. - ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) + ; checkTc (null stupid_theta || not gadt_syntax) (TcRnGADTDataContext tc_name) -- Check that there's at least one condecl, -- or else we're reading an hs-boot file, or -XEmptyDataDecls ; empty_data_decls <- xoptM LangExt.EmptyDataDecls ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) + ; unless (not (null cons) || empty_data_decls || is_boot) $ + addErrTc (TcRnEmptyDataDeclsDisabled tc_name) ; return gadt_syntax } @@ -3385,7 +3552,7 @@ concatMapDataDefnConsTcM name f = \ case NewTypeCon a -> f NewType a >>= \ case b:|[] -> pure (NewTypeCon b) - bs -> failWithTc $ newtypeConError name (length bs) + bs -> failWithTc $ TcRnMultipleConForNewtype name (length bs) DataTypeCons is_type_data as -> DataTypeCons is_type_data <$> concatMapM (fmap toList . f DataType) as tcConDecl :: NewOrData @@ -3457,12 +3624,13 @@ -- See test dependent/should_fail/T13780a -- Zonk to Types - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, tc_bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; (ze, kvs) <- zonkTyBndrsX ze kvs - ; (ze, exp_tvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs - ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs ) $ \ tc_bndrs -> + runZonkBndrT (zonkTyBndrsX kvs ) $ \ kvs -> + runZonkBndrT (zonkTyVarBindersX exp_tvbndrs) $ \ exp_tvbndrs -> + do { arg_tys <- zonkScaledTcTypesToTypesX arg_tys + ; ctxt <- zonkTcTypesToTypesX ctxt + ; return (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) } -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) @@ -3545,12 +3713,13 @@ ; let tvbndrs = mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs - -- Zonk to Types - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, tvbndrs) <- zonkTyVarBindersX ze tvbndrs - ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty + -- Zonk to Types + ; (tvbndrs, arg_tys, ctxt, res_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tvbndrs) $ \ tvbndrs -> + do { arg_tys <- zonkScaledTcTypesToTypesX arg_tys + ; ctxt <- zonkTcTypesToTypesX ctxt + ; res_ty <- zonkTcTypeToTypeX res_ty + ; return (tvbndrs, arg_tys, ctxt, res_ty) } ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) @@ -4069,8 +4238,7 @@ tv_kind = tyVarKind t_tv tv_kind' = substTy t_sub tv_kind t_tv' = setTyVarKind t_tv tv_kind' - eqs' | isConstraintLikeKind (typeKind tv_kind') = eqs - | otherwise = (t_tv', r_ty) : eqs + eqs' = (t_tv', r_ty) : eqs | otherwise = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) @@ -4263,9 +4431,7 @@ ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" } + ; checkTc hsBoot $ TcRnAbstractClosedTyFamDecl } ; DataFamilyTyCon {} -> return () ; OpenSynFamilyTyCon -> return () ; BuiltInSynFamTyCon _ -> return () } @@ -4341,12 +4507,11 @@ checkPartialRecordField all_cons fld = setSrcSpan loc $ warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) - (mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ - sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) + (TcRnPartialFieldSelector fld) where - loc = getSrcSpan (flSelector fld) - occ_name = occName fld + sel = flSelector fld + loc = getSrcSpan sel + occ_name = nameOccName sel (cons_with_field, cons_without_field) = partition has_field all_cons has_field con = fld `elem` (dataConFieldLabels con) @@ -4358,8 +4523,8 @@ checkFieldCompat :: FieldLabelString -> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcM () checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 - = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) - ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } + = do { checkTc (isJust mb_subst1) (TcRnCommonFieldResultTypeMismatch con1 con2 fld) + ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) } where mb_subst1 = tcMatchTy res1 res2 mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 @@ -4393,7 +4558,7 @@ -- data instance D [a] where { MkD :: D (Maybe b) } -- see Note [GADT return types] ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty)) - (badDataConTyCon con res_ty_tmpl) + (TcRnDataConParentTypeMismatch con res_ty_tmpl) -- Note that checkTc aborts if it finds an error. This is -- critical to avoid panicking when we call dataConDisplayType -- on an un-rejiggable datacon! @@ -4436,8 +4601,8 @@ ; checkValidType ctxt data_con_display_type -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) + ; unless (existential_ok || isVanillaDataCon con) $ + addErrTc (TcRnExistentialQuantificationDisabled con) -- Check that the only constraints in signatures of constructors -- in a "type data" declaration are equality constraints. @@ -4452,16 +4617,14 @@ check_bang orig_arg_ty bang rep_bang n | HsSrcBang _ _ SrcLazy <- bang , not (bang_opt_strict_data bang_opts) - = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (bad_bang n (text "Lazy annotation (~) without StrictData")) + = addErrTc (bad_bang n LazyFieldsDisabled) -- Warn about UNPACK without "!" -- e.g. data T = MkT {-# UNPACK #-} Int | HsSrcBang _ want_unpack strict_mark <- bang , isSrcUnpacked want_unpack, not (is_strict strict_mark) , not (isUnliftedType orig_arg_ty) - = addDiagnosticTc $ mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) + = addDiagnosticTc (bad_bang n UnpackWithoutStrictness) -- Warn about a redundant ! on an unlifted type -- e.g. data T = MkT !Int# @@ -4490,8 +4653,7 @@ -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addDiagnosticTc $ mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma")) + = addDiagnosticTc (bad_bang n BackpackUnpackAbstractType) | otherwise = return () @@ -4526,9 +4688,8 @@ NoSrcStrict -> bang_opt_strict_data bang_opts bang -> isSrcStrict bang - bad_bang n herald - = hang herald 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) + bad_bang n + = TcRnBadFieldAnnotation n con show_linear_types = xopt LangExt.LinearTypes dflags data_con_display_type = dataConDisplayType show_linear_types con @@ -4597,8 +4758,9 @@ -- extension (subsumed by multiparameter type classes, #8993) ; checkTc (multi_param_type_classes || cls_arity == 1 || (nullary_type_classes && cls_arity == 0)) - (classArityErr cls_arity cls) - ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) + (TcRnClassExtensionDisabled cls (MultiParamDisabled cls_arity)) + ; unless (fundep_classes || null fundeps) $ + addErrTc (TcRnClassExtensionDisabled cls FunDepsDisabled) -- Check the super-classes ; checkValidTheta (ClassSCCtxt (className cls)) theta @@ -4608,7 +4770,7 @@ ; unless undecidable_super_classes $ case checkClassCycles cls of Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints err) + addErrTc (TcRnSuperclassCycle err) Nothing -> return () -- Check the class operations. @@ -4659,14 +4821,16 @@ check_constraint pred -- See Note [Class method constraints] = when (not (isEmptyVarSet pred_tvs) && pred_tvs `subVarSet` cls_tv_set) - (addErrTc (badMethPred sel_id pred)) + (addErrTc (TcRnClassExtensionDisabled cls (ConstrainedClassMethodsDisabled sel_id pred))) where pred_tvs = tyCoVarsOfType pred check_at (ATI fam_tc m_dflt_rhs) = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs) - ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) - (noClassTyVarErr cls fam_tc) + ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + InvalidAssoc $ InvalidAssocInstance $ + AssocNoClassTyVar cls fam_tc -- Check that the associated type mentions at least -- one of the class type variables -- The check is disabled for nullary type classes, @@ -4751,12 +4915,7 @@ -- default foo2 :: a -> b unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "The default type signature for" - <+> ppr sel_id <> colon) - 2 (ppr dm_ty) - $$ (text "does not match its corresponding" - <+> text "non-default type signature") + TcRnDefaultSigMismatch sel_id dm_ty -- Now do an ambiguity check on the default type signature. checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) @@ -4768,19 +4927,12 @@ -- client might have a go! checkFamFlag tc_name = do { idx_tys <- xoptM LangExt.TypeFamilies - ; checkTc idx_tys err_msg } - where - err_msg :: TcRnMessage - err_msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") + ; unless idx_tys $ addErrTc (TcRnTyFamsDisabled (TyFamsDisabledFamily tc_name)) } checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () checkResultSigFlag tc_name (TyVarSig _ tvb) = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilyDependencies to allow result variable names") } + ; unless ty_fam_deps $ addErrTc (TcRnTyFamResultDisabled tc_name tvb) } checkResultSigFlag _ _ = return () -- other cases OK {- Note [Class method constraints] @@ -5013,15 +5165,19 @@ | isVisibleTyConBinder tvb = Just (role, binderVar tvb) | otherwise = Nothing - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> + check_roles = case role_annot_decl_maybe of + Nothing -> + setSrcSpan (getSrcSpan name) $ + -- See Note [Missing role annotations warning] + warnIf (not (isClassTyCon tc) && not (null vis_roles)) $ + TcRnMissingRoleAnnotation name vis_roles + Just (decl@(L loc (RoleAnnotDecl _ _ the_role_annots))) -> addRoleAnnotCtxt name $ setSrcSpanA loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations - ; checkTc role_annots_ok $ needXRoleAnnotations tc + ; unless role_annots_ok $ addErrTc $ TcRnRoleAnnotationsDisabled tc ; checkTc (vis_vars `equalLength` the_role_annots) - (wrongNumberOfRoles vis_vars decl) + (TcRnRoleCountMismatch (length vis_vars) decl) ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles -- Representational or phantom roles for class parameters -- quickly lead to incoherence. So, we require @@ -5030,7 +5186,7 @@ ; checkTc ( incoherent_roles_ok || (not $ isClassTyCon tc) || (all (== Nominal) vis_roles)) - incoherentRoles + (TcRnIncoherentRoles tc) ; lint <- goptM Opt_DoCoreLinting ; when lint $ checkValidRoles tc } @@ -5038,11 +5194,44 @@ check_no_roles = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl +-- Note [Missing role annotations warning] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We warn about missing role annotations for tycons +-- 1. not type-classes: +-- type classes are nominal by default, which is most conservative +-- choice. E.g. we cannot have a type-class with an (accidentally) +-- phantom or representational type variable, as we can with +-- data types. +-- 2. with visible roles +-- +-- We don't make any exceptions for other data types. +-- In particular we explicitly warn about omitted (default and common) +-- representational roles. That is the point of the warning. +-- For example the default representational role for `Map`s key type parameter +-- would be wrong, and this warning is there to warn about it, +-- asking users to be explicit. +-- +-- If the default roles have been nominal, i.e. as conservative as possible, +-- the warning would still be valuable, as most types can be `representational` +-- (c.f. type-classes, which usually cannot). +-- +-- We don't warn about types with invisible roles only, because users cannot +-- specify them: +-- +-- type Foo :: forall {k}. Type +-- data Foo = Foo Int +-- type role Foo phantom +-- +-- is incorrect, GHC complains: +-- Wrong number of roles listed in role annotation; +-- Expected 0, got 1: +-- + checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () checkRoleAnnot _ (L _ Nothing) _ = return () checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $ - addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 + addErrTc $ TcRnRoleMismatch (tyVarName tv) r1 r2 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils @@ -5078,11 +5267,8 @@ check_ty_roles env role (TyVarTy tv) = case lookupVarEnv env tv of Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "cannot have role" <+> ppr role <+> - text "because it was assigned role" <+> ppr role' - Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "missing in environment" + report_error role $ TyVarRoleMismatch tv role' + Nothing -> report_error role $ TyVarMissingInEnv tv check_ty_roles env Representational (TyConApp tc tys) = let roles' = tyConRoles tc in @@ -5114,17 +5300,14 @@ check_ty_roles _ role (CoercionTy co) = unless (role == Phantom) $ - report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role + report_error role $ BadCoercionRole co maybe_check_ty_roles env role ty = when (role == Nominal || role == Representational) $ check_ty_roles env role ty - report_error doc - = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + report_error role reason + = addErrTc $ TcRnRoleValidationFailed role reason {- ************************************************************************ @@ -5140,7 +5323,7 @@ addVDQNote :: TcTyCon -> TcM a -> TcM a -- See Note [Inferring visible dependent quantification] --- Only types without a signature (CUSK or SAK) here +-- Only types without a signature (CUSK or SAKS) here addVDQNote tycon thing_inside | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind) has_vdq @@ -5202,19 +5385,6 @@ ctxt = text "In the equations for closed type family" <+> quotes (ppr tc) -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage -resultTypeMisMatch field_name con1 con2 - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "have a common field" <+> quotes (ppr field_name) <> comma], - nest 2 $ text "but have different result types"] - -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage -fieldTypeMisMatch field_name con1 con2 - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons) <+> ppr_cons (toList cons) @@ -5231,147 +5401,11 @@ classOpCtxt sel_id tau = sep [text "When checking the class method:", nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] -classArityErr :: Int -> Class -> TcRnMessage -classArityErr n cls - | n == 0 = mkErr "No" "no-parameter" - | otherwise = mkErr "Too many" "multi-parameter" - where - mkErr howMany allowWhat = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (text ("Enable MultiParamTypeClasses to allow " - ++ allowWhat ++ " classes"))] - -classFunDepsErr :: Class -> TcRnMessage -classFunDepsErr cls - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Fundeps in class" <+> quotes (ppr cls), - parens (text "Enable FunctionalDependencies to allow fundeps")] - -badMethPred :: Id -> TcPredType -> TcRnMessage -badMethPred sel_id pred - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Constraint" <+> quotes (ppr pred) - <+> text "in the type of" <+> quotes (ppr sel_id)) - 2 (text "constrains only the class type variables") - , text "Enable ConstrainedClassMethods to allow it" ] - -noClassTyVarErr :: Class -> TyCon -> TcRnMessage -noClassTyVarErr clas fam_tc - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) - , text "mentions none of the type or kind variables of the class" <+> - quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] - -badDataConTyCon :: DataCon -> Type -> TcRnMessage -badDataConTyCon data_con res_ty_tmpl - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Data constructor" <+> quotes (ppr data_con) <+> - text "returns type" <+> quotes (ppr actual_res_ty)) - 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) - where - actual_res_ty = dataConOrigResTy data_con - -badGadtDecl :: Name -> TcRnMessage -badGadtDecl tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) - , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] - -badExistential :: DataCon -> TcRnMessage -badExistential con - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sdocOption sdocLinearTypes (\show_linear_types -> - hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) - -badStupidTheta :: Name -> TcRnMessage -badStupidTheta tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - -newtypeConError :: Name -> Int -> TcRnMessage -newtypeConError tycon n - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] - -badSigTyDecl :: Name -> TcRnMessage -badSigTyDecl tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal kind signature" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] - -emptyConDeclsErr :: Name -> TcRnMessage -emptyConDeclsErr tycon - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [quotes (ppr tycon) <+> text "has no constructors", - nest 2 $ text "(EmptyDataDecls permits this)"] - -wrongKindOfFamily :: TyCon -> TcRnMessage -wrongKindOfFamily family - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Wrong category of family instance; declaration was for a" - <+> kindOfFamily - where - kindOfFamily | isTypeFamilyTyCon family = text "type family" - | isDataFamilyTyCon family = text "data family" - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - --- | Produce an error for oversaturated type family equations with too many --- required arguments. --- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". -wrongNumberOfParmsErr :: Arity -> TcRnMessage -wrongNumberOfParmsErr max_args - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Number of parameters must match family declaration; expected" - <+> ppr max_args - -badRoleAnnot :: Name -> Role -> Role -> TcRnMessage -badRoleAnnot var annot inferred - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Role mismatch on variable" <+> ppr var <> colon) - 2 (sep [ text "Annotation says", ppr annot - , text "but role", ppr inferred - , text "is required" ]) - -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Wrong number of roles listed in role annotation;" $$ - text "Expected" <+> (ppr $ length tyvars) <> comma <+> - text "got" <+> (ppr $ length annots) <> colon) - 2 (ppr d) - - illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) +illegalRoleAnnotDecl (L loc role) = setErrCtxt [] $ setSrcSpanA loc $ - addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") - -needXRoleAnnotations :: TyCon -> TcRnMessage -needXRoleAnnotations tc - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal role annotation for" <+> ppr tc <> char ';' $$ - text "did you intend to use RoleAnnotations?" - -incoherentRoles :: TcRnMessage -incoherentRoles = mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") - -wrongTyFamName :: Name -> Name -> TcRnMessage -wrongTyFamName fam_tc_name eqn_tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Mismatched type name in type family instance.") - 2 (vcat [ text "Expected:" <+> ppr fam_tc_name - , text " Actual:" <+> ppr eqn_tc_name ]) + addErrTc $ TcRnIllegalRoleAnnotation role addTyConCtxt :: TyCon -> TcM a -> TcM a addTyConCtxt tc = addTyConFlavCtxt name flav 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 @@ -35,21 +35,24 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify -import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) +import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) -import GHC.Core.Predicate -import GHC.Core.Multiplicity import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build( TcMethInfo ) + +import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) +import GHC.Core.Predicate +import GHC.Core.Multiplicity import GHC.Core.Class import GHC.Core.Coercion ( pprCoAxiom ) -import GHC.Driver.Session -import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv +import GHC.Core.TyCon + +import GHC.Driver.DynFlags + import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name @@ -58,13 +61,14 @@ import GHC.Types.Var import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) +import GHC.Types.SrcLoc +import GHC.Types.Basic + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Types.SrcLoc -import GHC.Core.TyCon + import GHC.Data.Maybe -import GHC.Types.Basic import GHC.Data.Bag import GHC.Data.BooleanFormula @@ -597,6 +601,8 @@ -- hs-boot and signatures never need to provide complete "definitions" -- of any sort, as they aren't really defining anything, but just -- constraining items which are defined elsewhere. - ; let dia = TcRnNoExplicitAssocTypeOrDefaultDeclaration name - ; diagnosticTc (warn && hsc_src == HsSrcFile) dia + ; let diag = TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocInstanceMissing name + ; diagnosticTc (warn && hsc_src == HsSrcFile) diag } 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 @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -21,6 +22,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Rename.Bind ( rejectBootDecls ) import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl @@ -32,7 +34,8 @@ import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad import GHC.Tc.Validity -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint @@ -48,6 +51,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType import GHC.Tc.Utils.Unify +import GHC.Builtin.Names ( unsatisfiableIdName ) import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) @@ -67,11 +71,12 @@ import GHC.Data.Bag import GHC.Types.Basic import GHC.Types.Fixity -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id +import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Data.List.SetOps import GHC.Types.Name @@ -485,7 +490,7 @@ , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) - = setSrcSpanA loc $ + = setSrcSpanA loc $ addErrCtxt (instDeclCtxt1 hs_ty) $ do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty @@ -552,11 +557,13 @@ all_insts = tyfam_insts ++ datafam_insts -- In hs-boot files there should be no bindings - ; let no_binds = isEmptyLHsBinds binds && null uprags - ; is_boot <- tcIsHsBootOrSig - ; failIfTc (is_boot && not no_binds) TcRnIllegalHsBootFileDecl - - ; return ( [inst_info], all_insts, deriv_infos ) } + ; gbl_env <- getGblEnv; + ; case tcg_src gbl_env of + { HsSrcFile -> return () + ; HsBootOrSig boot_or_sig -> + do { rejectBootDecls boot_or_sig BootBindsRn (bagToList binds) + ; rejectBootDecls boot_or_sig BootInstanceSigs uprags } } + ; return ([inst_info], all_insts, deriv_infos) } where defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) `unionNameSet` @@ -586,11 +593,15 @@ tcAddTyFamInstCtxt decl $ do { let fam_lname = feqn_tycon eqn ; fam_tc <- tcLookupLocatedTyCon fam_lname - ; tcFamInstDeclChecks mb_clsinfo fam_tc + ; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc -- (0) Check it's an open type family - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (TcRnNotOpenFamily fam_tc) + ; checkTc (isTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc + ; checkTc (isOpenTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + NotAnOpenFamilyTyCon fam_tc -- (1) do the work of verifying the synonym group -- For some reason we don't have a location for the equation @@ -609,24 +620,32 @@ --------------------- -tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () +tcFamInstDeclChecks :: AssocInstInfo -> TypeOrData -> TyCon -> TcM () -- Used for both type and data families -tcFamInstDeclChecks mb_clsinfo fam_tc +tcFamInstDeclChecks mb_clsinfo ty_or_data fam_tc = do { -- Type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file ; traceTc "tcFamInstDecl" (ppr fam_tc) ; type_families <- xoptM LangExt.TypeFamilies - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families (TcRnBadFamInstDecl fam_tc) - ; checkTc (not is_boot) TcRnBadBootFamInstDecl + ; hs_src <- tcHscSource -- Are we compiling an hs-boot file? + ; checkTc type_families (TcRnTyFamsDisabled (TyFamsDisabledInstance fam_tc)) + ; case hs_src of + HsBootOrSig boot_or_sig -> + addErrTc $ TcRnIllegalHsBootOrSigDecl boot_or_sig (BootFamInst fam_tc) + HsSrcFile -> + return () - -- Check that it is a family TyCon, and that - -- oplevel type instances are not for associated types. - ; checkTc (isFamilyTyCon fam_tc) (TcRnIllegalFamilyInstance fam_tc) + -- Check that it is a family TyCon + ; checkTc (isFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + NotAFamilyTyCon ty_or_data fam_tc + -- Check that top-level type instances are not for associated types. ; when (isNotAssociated mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ TcRnMissingClassAssoc fam_tc) + isTyConAssoc fam_tc) $ -- but an associated type + addErr $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocInstanceNotInAClass fam_tc } {- Note [Associated type instances] @@ -681,10 +700,12 @@ tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupLocatedTyCon lfam_name - ; tcFamInstDeclChecks mb_clsinfo fam_tc + ; tcFamInstDeclChecks mb_clsinfo IAmData fam_tc -- Check that the family declaration is for the right kind - ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isDataFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc ; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in GHC.Core.FamInstEnv @@ -739,17 +760,21 @@ , text "eta_tcbs" <+> ppr eta_tcbs ] -- Zonk the patterns etc into the Type world - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, ty_binders) <- zonkTyVarBindersX ze tc_ty_binders - ; res_kind <- zonkTcTypeToTypeX ze tc_res_kind - ; all_pats <- zonkTcTypesToTypesX ze all_pats - ; eta_pats <- zonkTcTypesToTypesX ze eta_pats - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs - zonked_eta_tvs = map (lookupTyVarX ze) eta_tvs - -- All these qtvs are in ty_binders, and hence will be in - -- the ZonkEnv, ze. We need the zonked (TyVar) versions to - -- put in the CoAxiom that we are about to build. + ; (ty_binders, res_kind, all_pats, eta_pats, stupid_theta, + zonked_post_eta_qtvs, zonked_eta_tvs) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_ty_binders) $ \ ty_binders -> + do { res_kind <- zonkTcTypeToTypeX tc_res_kind + ; all_pats <- zonkTcTypesToTypesX all_pats + ; eta_pats <- zonkTcTypesToTypesX eta_pats + ; stupid_theta <- zonkTcTypesToTypesX stupid_theta + ; zonked_post_eta_qtvs <- mapM lookupTyVarX post_eta_qtvs + ; zonked_eta_tvs <- mapM lookupTyVarX eta_tvs + -- All these qtvs are in ty_binders, and hence will be in + -- the ZonkEnv, ze. We need the zonked (TyVar) versions to + -- put in the CoAxiom that we are about to build. + ; return (ty_binders, res_kind, all_pats, eta_pats, stupid_theta, + zonked_post_eta_qtvs, zonked_eta_tvs) } ; traceTc "tcDataFamInstDecl" $ vcat [ text "Fam tycon:" <+> ppr fam_tc @@ -948,11 +973,14 @@ -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted - ; final_tvs <- zonkTcTyVarsToTcTyVars final_tvs - ; lhs_ty <- zonkTcType lhs_ty - ; master_res_kind <- zonkTcType master_res_kind - ; instance_res_kind <- zonkTcType instance_res_kind - ; stupid_theta <- zonkTcTypes stupid_theta + ; (final_tvs,lhs_ty,master_res_kind,instance_res_kind,stupid_theta) <- + liftZonkM $ do + { final_tvs <- zonkTcTyVarsToTcTyVars final_tvs + ; lhs_ty <- zonkTcType lhs_ty + ; master_res_kind <- zonkTcType master_res_kind + ; instance_res_kind <- zonkTcType instance_res_kind + ; stupid_theta <- zonkTcTypes stupid_theta + ; return (final_tvs,lhs_ty,master_res_kind,instance_res_kind,stupid_theta) } -- Check that res_kind is OK with checkDataKindSig. We need to -- check that it's ok because res_kind can come from a user-written @@ -1463,7 +1491,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 + ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id True sc_ev_tm ; let sc_top_ty = tcMkDFunSigmaTy tyvars (map idType dfun_evs) sc_pred sc_top_id = mkLocalId sc_top_name ManyTy sc_top_ty export = ABE { abe_wrap = idHsWrapper @@ -1644,7 +1672,7 @@ it is the superclass of an unblocked dictionary (wrinkle (W1)), that is Paterson-smaller than the instance head. - This is implemented in GHC.Tc.Solver.Canonical.mk_strict_superclasses + This is implemented in GHC.Tc.Solver.Dict.mk_strict_superclasses (in the mk_given_loc helper function). * Superclass "Wanted" constraints have CtOrigin of (ScOrigin NakedSc) @@ -1655,7 +1683,7 @@ origin. But if we apply an instance declaration, we can set the origin to (ScOrigin NotNakedSc), thus lifting any restrictions by making prohibitedSuperClassSolve return False. This happens - in GHC.Tc.Solver.Interact.checkInstanceOK. + in GHC.Tc.Solver.Dict.checkInstanceOK. * (sc2) ScOrigin wanted constraints can't be solved from a superclass selection, except at a smaller type. This test is @@ -1668,12 +1696,12 @@ breaking their code going when upgrading to GHC 9.6. To this effect, we temporarily continue to allow the constraint solver to create these potentially non-terminating solutions, but emit a loud warning when doing so: see -GHC.Tc.Solver.Interact.tryLastResortProhibitedSuperclass. +GHC.Tc.Solver.Dict.tryLastResortProhibitedSuperclass. Users can silence the warning by manually adding the necessary constraint to the context. GHC will then keep this user-written Given, dropping the Given arising from superclass expansion which has greater SC depth, as explained in -Note [Replacement vs keeping] in GHC.Tc.Solver.Interact. +Note [Replacement vs keeping] in GHC.Tc.Solver.Dict. Note [Silent superclass arguments] (historical interest only) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1785,6 +1813,9 @@ hs_sig_fn = mkHsSigFun sigs inst_loc = getSrcSpan dfun_id + unsat_thetas = + mapMaybe (\ id -> (id,) <$> isUnsatisfiableCt_maybe (idType id)) dfun_ev_vars + ---------------------- tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) tc_item (sel_id, dm_info) @@ -1801,25 +1832,51 @@ tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind GhcTc, Maybe Implication) - tc_default sel_id (Just (dm_name, _)) - = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name + tc_default sel_id mb_dm = case mb_dm of + + -- If the instance has an "Unsatisfiable msg" context, + -- add method bindings that use "unsatisfiable". + -- + -- See Note [Implementation of Unsatisfiable constraints], + -- in GHC.Tc.Errors, point (D). + _ | (theta_id,unsat_msg) : _ <- unsat_thetas + -> do { (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + ; unsat_id <- tcLookupId unsatisfiableIdName + -- Recall that unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + -- + -- So we need to instantiate the forall and pass the dictionary evidence. + ; let meth_rhs = L inst_loc' $ + wrapId + ( mkWpEvApps [EvExpr $ Var theta_id] + <.> mkWpTyApps [getRuntimeRep meth_tau, unsat_msg, meth_tau]) + unsat_id + meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs + ; return (meth_id, meth_bind, Nothing) } + + Just (dm_name, _) -> + do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name ; tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags inline_prags sel_id meth_bind inst_loc } - tc_default sel_id Nothing -- No default method at all - = do { traceTc "tc_def: warn" (ppr sel_id) + -- No default method + Nothing -> + do { traceTc "tc_def: warn" (ppr sel_id) ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; dflags <- getDynFlags - ; let meth_bind = mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags) + -- Add a binding whose RHS is an error + -- "No explicit nor default method for class operation 'meth'". + ; let meth_rhs = error_rhs dflags + meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs ; return (meth_id, meth_bind, Nothing) } + where inst_loc' = noAnnSrcSpan inst_loc error_rhs dflags = L inst_loc' - $ HsApp noComments error_fun (error_msg dflags) + $ HsApp noComments error_fun (error_msg dflags) error_fun = L inst_loc' $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) @@ -1829,13 +1886,18 @@ (unsafeMkByteString (error_string dflags)))) meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags - (hcat [ppr inst_loc, vbar, ppr sel_id ]) + (hcat [ppr inst_loc, vbar, quotes (ppr sel_id) ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars ---------------------- -- Check if one of the minimal complete definitions is satisfied checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + = when (null unsat_thetas) $ + -- Don't warn if there is an "Unsatisfiable" constraint in the context. + -- + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (D). + whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ warnUnsatisfiedMinimalDefinition methodExists meth = isJust (findMethodBind meth binds prag_fn) @@ -1907,17 +1969,15 @@ instances in order to determine which cases were unreachable. This seems like a lot of work for minimal gain, so we have opted not to go for this approach. -Instead, we take the much simpler approach of always disabling --Winaccessible-code for derived code. To accomplish this, we do the following: +Instead, we take the following approach: -1. In tcMethods (which typechecks method bindings), disable - -Winaccessible-code. +1. In tcMethods (which typechecks method bindings), use 'setInGeneratedCode'. 2. When creating Implications during typechecking, record this flag (in ic_warn_inaccessible) at the time of creation. 3. After typechecking comes error reporting, where GHC must decide how to report inaccessible code to the user, on an Implication-by-Implication - basis. If an Implication's DynFlags indicate that -Winaccessible-code was - disabled, then don't bother reporting it. That's it! + basis. If the ic_warn_inaccessible field of the Implication is False, then + we don't bother reporting it. That's it! -} ------------------------ @@ -2063,7 +2123,7 @@ poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) methSigCtxt sel_name sig_ty meth_ty env0 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty @@ -2166,7 +2226,7 @@ , tyConBinderForAllTyFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys bind = L (noAnnSrcSpan loc) - $ mkTopFunBind Generated fn + $ mkTopFunBind (Generated SkipPmc) fn [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body" 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 @@ -23,9 +23,10 @@ import GHC.Tc.Gen.Pat import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad +import GHC.Tc.Zonk.TcType import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv , addInlinePrags, addInlinePragArity ) import GHC.Tc.Solver @@ -41,7 +42,6 @@ import GHC.Core.Predicate import GHC.Builtin.Types.Prim -import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc @@ -61,13 +61,14 @@ import GHC.Core.ConLike import GHC.Types.FieldLabel import GHC.Rename.Env -import GHC.Rename.Utils (wrapGenSpan) +import GHC.Rename.Utils (wrapGenSpan, isIrrefutableHsPatRn) import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors ) +import GHC.Driver.DynFlags ( getDynFlags, xopt_FieldSelectors ) import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) +import Data.List.NonEmpty (NonEmpty, nonEmpty) {- ************************************************************************ @@ -175,7 +176,7 @@ ; top_ev_binds <- checkNoErrs (simplifyTop residual) ; addTopEvBinds top_ev_binds $ - do { prov_dicts <- mapM zonkId prov_dicts + do { prov_dicts <- liftZonkM $ mapM zonkId prov_dicts ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts -- Filtering: see Note [Remove redundant provided dicts] (prov_theta, prov_evs) @@ -184,22 +185,21 @@ -- Report coercions that escape -- See Note [Coercions that escape] - ; args <- mapM zonkId args - ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts - , let bad_cos = filterDVarSet isId $ - (tyCoVarsOfTypeDSet (idType arg)) - , not (isEmptyDVarSet bad_cos) ] + ; args <- liftZonkM $ mapM zonkId args + ; let bad_arg arg = fmap (\bad_cos -> (arg, bad_cos)) $ + nonEmpty $ + dVarSetElems $ + filterDVarSet isId (tyCoVarsOfTypeDSet (idType arg)) + bad_args = mapMaybe bad_arg (args ++ prov_dicts) ; mapM_ dependentArgErr bad_args -- Report un-quantifiable type variables: -- see Note [Unquantified tyvars in a pattern synonym] ; dvs <- candidateQTyVarsOfTypes prov_theta - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta - ; return ( tidy_env2 - , sep [ text "the provided context:" - , pprTheta theta ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; return ( tidy_env2, UninfTyCtx_ProvidedContext theta ) } + ; doNotQuantifyTyVars dvs err_ctx ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) ; rec_fields <- lookupConstructorFields name @@ -238,22 +238,11 @@ pred = evVarPred ev_id eq_con_args = [evId ev_id] -dependentArgErr :: (Id, DTyCoVarSet) -> TcM () +dependentArgErr :: (Id, NonEmpty CoVar) -> TcM () -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) = failWithTc $ -- fail here: otherwise we get downstream errors - mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" - , hang (text "Pattern-bound variable") - 2 (ppr arg <+> dcolon <+> ppr (idType arg)) - , nest 2 $ - hang (text "has a type that mentions pattern-bound coercion" - <> plural bad_co_list <> colon) - 2 (pprWithCommas ppr bad_co_list) - , text "Hint: use -fprint-explicit-coercions to see the coercions" - , text "Probable fix: add a pattern signature" ] - where - bad_co_list = dVarSetElems bad_cos + TcRnPatSynEscapedCoercion arg bad_cos {- Note [Type variables whose kind is captured] ~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -407,11 +396,7 @@ -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity (decl_arity above) ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs - ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma - , text "namely" <+> quotes (ppr pat_ty) ]) - 2 (text "mentions existential type variable" <> plural bad_tvs - <+> pprQuotedList bad_tvs) + ; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig ; let univ_fvs = closeOverKinds $ @@ -681,10 +666,7 @@ wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" - <+> speakNOf decl_arity (text "argument")) - 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") + = failWithTc $ TcRnPatSynArityMismatch name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn @@ -711,21 +693,25 @@ = do { -- Zonk everything. We are about to build a final PatSyn -- so there had better be no unification variables in there - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, univ_tvs') <- zonkTyVarBindersX ze univ_tvs - ; req_theta' <- zonkTcTypesToTypesX ze req_theta - ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs - ; prov_theta' <- zonkTcTypesToTypesX ze prov_theta - ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty - ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys + (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> + do { req_theta' <- zonkTcTypesToTypesX req_theta + ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> + do { prov_theta' <- zonkTcTypesToTypesX prov_theta + ; pat_ty' <- zonkTcTypeToTypeX pat_ty + ; arg_tys' <- zonkTcTypesToTypesX arg_tys - ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' - prov_theta = tidyTypes env2 prov_theta' - arg_tys = tidyTypes env2 arg_tys' - pat_ty = tidyType env2 pat_ty' + ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' + req_theta = tidyTypes env2 req_theta' + prov_theta = tidyTypes env2 prov_theta' + arg_tys = tidyTypes env2 arg_tys' + pat_ty = tidyType env2 pat_ty' + ; return (univ_tvs, req_theta, + ex_tvs, prov_theta, arg_tys, pat_ty) } } + ; traceTc "tc_patsyn_finish {" $ ppr (unLoc lname) $$ ppr (unLoc lpat') $$ ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ @@ -822,21 +808,22 @@ args = map nlVarPat [scrutinee, cont, fail] lwpat = noLocA $ WildPat pat_ty - cases = if isIrrefutableHsPat dflags lpat + cases = if isIrrefutableHsPatRn dflags lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] + gen = Generated SkipPmc body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ - HsCase noExtField (nlHsVar scrutinee) $ + HsCase PatSyn (nlHsVar scrutinee) $ MG{ mg_alts = L (l2l $ getLoc lpat) cases - , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen } body' = noLocA $ HsLam noExtField $ MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr args body] - , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty gen } match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) [] (mkHsLams (rr_tv:res_tv:univ_tvs) @@ -844,7 +831,7 @@ (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (l2l $ getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty Generated + , mg_ext = MatchGroupTc [] res_ty gen } matcher_arity = length req_theta + 3 -- See Note [Pragmas for pattern synonyms] @@ -923,11 +910,7 @@ = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr ps_name) <> colon) - 2 why - , text "RHS pattern:" <+> ppr lpat ] + = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why | Right match_group <- mb_match_group -- Bidirectional = do { patsyn <- tcLookupPatSyn ps_name @@ -977,11 +960,11 @@ mb_match_group = case dir of ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat) + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated (noLocA [builder_match]) + mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match]) where builder_args = [L (na2la loc) (VarPat noExtField (L loc n)) | L loc n <- args] @@ -1021,8 +1004,8 @@ | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn - -> Either SDoc (LHsExpr GhcRn) +tcPatToExpr :: [LocatedN Name] -> LPat GhcRn + -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the @@ -1031,13 +1014,13 @@ -- -- Returns (Left r) if the pattern is not invertible, for reason r. -- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr name args pat = go pat +tcPatToExpr args pat = go pat where lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] - -> Either SDoc (HsExpr GhcRn) + -> Either PatSynInvalidRhsReason (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats ; let con = L (l2l loc) (HsVar noExtField lcon) @@ -1045,18 +1028,18 @@ } mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either SDoc (HsExpr GhcRn) + -> Either PatSynInvalidRhsReason (HsExpr GhcRn) mkRecordConExpr con (HsRecFields fields dd) = do { exprFields <- mapM go' fields ; return (RecordCon noExtField con (HsRecFields exprFields dd)) } - go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn)) + go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn)) go' (L l rf) = L l <$> traverse go rf - go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) + go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn) + go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn) go1 (ConPat NoExtField con info) = case info of PrefixCon _ ps -> mkPrefixConExpr con ps @@ -1070,7 +1053,7 @@ | var `elemNameSet` lhsVars = return $ HsVar noExtField (L l var) | otherwise - = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") + = Left (PatSynUnboundVar var) go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat go1 (ListPat _ pats) = do { exprs <- mapM go pats @@ -1107,19 +1090,7 @@ go1 p@(AsPat {}) = notInvertible p go1 p@(NPlusKPat {}) = notInvertible p - notInvertible p = Left (not_invertible_msg p) - - not_invertible_msg p - = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" - $+$ hang (text "Suggestion: instead use an explicitly bidirectional" - <+> text "pattern synonym, e.g.") - 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow - <+> ppr pat <+> text "where") - 2 (pp_name <+> pp_args <+> equals <+> text "...")) - where - pp_name = ppr name - pp_args = hsep (map ppr args) - + notInvertible p = Left (PatSynNotInvertible p) {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -64,17 +64,16 @@ import GHC.Unit.Module -import GHC.Rename.Utils (wrapGenSpan) +import GHC.Rename.Utils (genHsVar, genLHsApp, genLHsLit, genWildPat) import GHC.Types.Basic -import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Name.Reader ( mkRdrUnqual ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Var.Env @@ -170,7 +169,7 @@ -- track of the TyCons which are known to be acyclic, or -- a failure message reporting that a cycle was found. newtype SynCycleM a = SynCycleM { - runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } + runSynCycleM :: SynCycleState -> Either (SrcSpan, TySynCycleTyCons) (a, SynCycleState) } deriving (Functor) -- TODO: TyConSet is implemented as IntMap over uniques. @@ -190,8 +189,8 @@ runSynCycleM (f x) state' Left err -> Left err -failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () -failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) +failSynCycleM :: SrcSpan -> TySynCycleTyCons -> SynCycleM () +failSynCycleM loc seen_tcs = SynCycleM $ \_ -> Left (loc, seen_tcs) -- | Test if a 'Name' is acyclic, short-circuiting if we've -- seen it already. @@ -211,7 +210,7 @@ checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) + Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnTypeSynonymCycle err) Right _ -> return () where -- Try our best to print the LTyClDecl for locally defined things @@ -228,9 +227,7 @@ go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM () go' so_far seen_tcs tc | tc `elemTyConSet` so_far - = failSynCycleM (getSrcSpan (head seen_tcs)) $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_decl seen_tcs)) ] + = failSynCycleM (getSrcSpan (head seen_tcs)) (lookup_decl <$> seen_tcs) -- Optimization: we don't allow cycles through external packages, -- so once we find a non-local name we are guaranteed to not -- have a cycle. @@ -247,13 +244,10 @@ where n = tyConName tc mod = nameModule n - ppr_decl tc = - case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n - <+> text "from external module" - where - n = tyConName tc + lookup_decl tc = + case lookupNameEnv lcl_decls (tyConName tc) of + Just decl -> Right decl + Nothing -> Left tc go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM () go_ty so_far seen_tcs ty = @@ -307,19 +301,14 @@ type ClassSet = UniqSet Class -checkClassCycles :: Class -> Maybe SDoc +checkClassCycles :: Class -> Maybe SuperclassCycle -- Nothing <=> ok -- Just err <=> possible cycle error checkClassCycles cls - = do { (definite_cycle, err) <- go (unitUniqSet cls) + = do { (definite_cycle, details) <- go (unitUniqSet cls) cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = text "Superclass cycle for" - | otherwise = text "Potential superclass cycle for" - ; return (vcat [ herald <+> quotes (ppr cls) - , nest 2 err, hint]) } + ; return (MkSuperclassCycle cls definite_cycle details) } where - hint = text "Use UndecidableSuperClasses to accept this" - -- Expand superclasses starting with (C a b), complaining -- if you find the same class a second time, or a type function -- or predicate headed by a type variable @@ -327,12 +316,12 @@ -- NB: this code duplicates TcType.transSuperClasses, but -- with more error message generation clobber -- Make sure the two stay in sync. - go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go :: ClassSet -> Class -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) go so_far cls tys = firstJusts $ map (go_pred so_far) $ immSuperClasses cls tys - go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc) + go_pred :: ClassSet -> PredType -> Maybe (Bool, [SuperclassCycleDetail]) -- Nothing <=> ok -- Just (True, err) <=> definite cycle -- Just (False, err) <=> possible cycle @@ -340,31 +329,28 @@ | Just (tc, tys) <- tcSplitTyConApp_maybe pred = go_tc so_far pred tc tys | hasTyVarHead pred - = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") - 2 (quotes (ppr pred))) + = Just (False, [SCD_HeadTyVar pred]) | otherwise = Nothing - go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) + go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) go_tc so_far pred tc tys | isFamilyTyCon tc - = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") - 2 (quotes (ppr pred))) + = Just (False, [SCD_HeadTyFam pred]) | Just cls <- tyConClass_maybe tc = go_cls so_far cls tys | otherwise -- Equality predicate, for example = Nothing - go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) go_cls so_far cls tys | cls `elementOfUniqSet` so_far - = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) + = Just (True, [SCD_Superclass cls]) | isCTupleClass cls = go so_far cls tys | otherwise - = do { (b,err) <- go (so_far `addOneToUniqSet` cls) cls tys - ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) - $$ err) } + = do { (b, details) <- go (so_far `addOneToUniqSet` cls) cls tys + ; return (b, SCD_Superclass cls : details) } {- ************************************************************************ @@ -898,7 +884,9 @@ sel_name = flSelector fl sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } + rec_details = RecSelId { sel_tycon = idDetails + , sel_naughty = is_naughty + , sel_fieldLabel = fl } -- Find a representative constructor, con1 cons_w_field = conLikesWithFields all_cons [lbl] @@ -942,7 +930,7 @@ -- make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated sel_lname alts + sel_bind = mkTopFunBind (Generated SkipPmc) sel_lname alts where alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) [] unit_rhs] @@ -956,7 +944,7 @@ { hfbAnn = noAnn , hfbLHS = L locc (FieldOcc sel_name - (L locn $ mkVarUnqual (field_label lbl))) + (L locn $ mkRdrUnqual (nameOccName sel_name))) , hfbRHS = L loc' (VarPat noExtField (L locn field_var)) , hfbPun = False }) @@ -968,11 +956,10 @@ -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [wrapGenSpan (WildPat noExtField)] - (wrapGenSpan - (HsApp noComments - (wrapGenSpan (HsVar noExtField (wrapGenSpan (getName rEC_SEL_ERROR_ID)))) - (wrapGenSpan (HsLit noComments msg_lit))))] + [genWildPat] + (genLHsApp + (genHsVar (getName rEC_SEL_ERROR_ID)) + (genLHsLit msg_lit))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs --- a/compiler/GHC/Tc/Types/EvTerm.hs +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -6,7 +6,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Tc.Types.Evidence 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 @@ -20,7 +20,7 @@ import GHC.Driver.Env import GHC.Driver.Ppr -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.Basic (TypeOrKind(..)) import GHC.Types.Fixity (defaultFixity) @@ -47,14 +47,18 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Module import GHC.Tc.Gen.Export import GHC.Tc.Solver import GHC.Tc.TyCl.Utils import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -71,11 +75,8 @@ import GHC.Rename.Names import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Tc.Utils.Env -import GHC.Tc.Errors -import GHC.Tc.Utils.Unify - import GHC.Utils.Error +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -86,36 +87,21 @@ import Control.Monad import Data.List (find) -import {-# SOURCE #-} GHC.Tc.Module - - -fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage -fixityMisMatch real_thing real_fixity sig_fixity = - mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ppr real_thing <+> text "has conflicting fixities in the module", - text "and its hsig file", - text "Main module:" <+> ppr_fix real_fixity, - text "Hsig file:" <+> ppr_fix sig_fixity] - where - ppr_fix f = - ppr f <+> - (if f == defaultFixity - then parens (text "default") - else empty) +import GHC.Iface.Errors.Types checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () checkHsigDeclM sig_iface sig_thing real_thing = do let name = getName real_thing -- TODO: Distinguish between signature merging and signature -- implementation cases. - checkBootDeclM False sig_thing real_thing + checkBootDeclM Hsig sig_thing real_thing real_fixity <- lookupFixityRn name let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of Nothing -> defaultFixity Just f -> f when (real_fixity /= sig_fixity) $ addErrAt (nameSrcSpan name) - (fixityMisMatch real_thing real_fixity sig_fixity) + (TcRnHsigFixityMismatch real_thing real_fixity sig_fixity) -- | Given a 'ModDetails' of an instantiated signature (note that the -- 'ModDetails' must be knot-tied consistently with the actual implementation) @@ -127,7 +113,7 @@ -- a sufficient set of entities, since otherwise the renaming and then -- typechecking of the signature 'ModIface' would have failed. checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () -checkHsigIface tcg_env gr sig_iface +checkHsigIface tcg_env gre_env sig_iface ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, md_types = sig_type_env, md_exports = sig_exports } = do traceTc "checkHsigIface" $ vcat @@ -135,8 +121,8 @@ mapM_ check_export (map availName sig_exports) failIfErrsM -- See Note [Fail before checking instances in checkHsigIface] unless (null sig_fam_insts) $ - panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") + panic ("GHC.Tc.Utils.Backpack.checkHsigIface: " ++ + "Cannot handle family instances in hsig files yet...") -- Delete instances so we don't look them up when -- checking instance satisfiability -- TODO: this should not be necessary @@ -168,14 +154,14 @@ -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr (TcRnInterfaceLookupError name err) + Failed err -> addErr (TcRnInterfaceError err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must -- be a reexport. In this case, make sure the 'Name' of the - -- reexport matches the 'Name exported here. - | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do - let name' = greMangledName gre + -- reexport matches the 'Name' exported here. + | [gre] <- lookupGRE gre_env (LookupOccName (nameOccName name) SameNameSpace) = do + let name' = greName gre when (name /= name') $ do -- See Note [Error reporting bad reexport] -- TODO: Actually this error swizzle doesn't work @@ -188,11 +174,11 @@ -> getLocA e _ -> nameSrcSpan name addErrAt loc - (badReexportedBootThing False name name') + (TcRnBootMismatch Hsig $ BadReexportedBootThing name name') -- This should actually never happen, but whatever... | otherwise = addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") + (missingBootThing Hsig name MissingBootExport) -- Note [Fail before checking instances in checkHsigIface] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -223,24 +209,25 @@ -- TODO: This could be very well generalized to support instance -- declarations in boot files. tcg_env <- getGblEnv + lcl_env <- getLclEnv + -- NB: Have to tug on the interface, not necessarily -- tugged... but it didn't work? mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) -- Based off of 'simplifyDeriv' - let origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst (skol_info, tvs_skols, inst_theta, cls, inst_tys) <- tcSkolDFunType (idType dfun_id) (tclvl,cts) <- pushTcLevelM $ do + given_ids <- mapM newEvVar inst_theta + let given_loc = mkGivenLoc topTcLevel skol_info (mkCtLocEnv lcl_env) + givens = [ CtGiven { ctev_pred = idType given_id + -- Doesn't matter, make something up + , ctev_evar = given_id + , ctev_loc = given_loc } + | given_id <- given_ids ] + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst wanted <- newWanted origin (Just TypeLevel) (mkClassPred cls inst_tys) - givens <- forM inst_theta $ \given -> do - loc <- getCtLocM origin (Just TypeLevel) - new_ev <- newEvVar given - return CtGiven { ctev_pred = given - -- Doesn't matter, make something up - , ctev_evar = new_ev - , ctev_loc = loc - } - return $ wanted : givens + return (wanted : givens) unsolved <- simplifyWantedsTcM cts (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved @@ -278,7 +265,7 @@ reqs = requirementMerges unit_state modname holes <- forM reqs $ \(Module iuid mod_name) -> do initIfaceLoad hsc_env - . withException ctx + . withIfaceErr ctx $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name) return (uniqDSetToList (unionManyUniqDSets holes)) @@ -400,7 +387,7 @@ decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) - exported_occs = mkOccSet [ occName n + exported_occs = mkOccSet [ nameOccName n | a <- avails , n <- availNames a ] exported_decls = filter_decls exported_occs @@ -510,7 +497,7 @@ -- from 'requirementMerges' into this signature, producing -- a final 'TcGblEnv' that matches the local signature and -- all required signatures. -mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv +mergeSignatures :: HasDebugCallStack => HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv mergeSignatures (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), hpm_src_files = src_files }) @@ -547,7 +534,7 @@ let outer_mod = tcg_mod tcg_env let inner_mod = tcg_semantic_mod tcg_env - let mod_name = moduleName (tcg_mod tcg_env) + let mod_name = moduleName outer_mod let unit_state = hsc_units hsc_env let dflags = hsc_dflags hsc_env @@ -563,9 +550,8 @@ im = fst (getModuleInstantiation m) ctx = initSDocContext dflags defaultUserStyle fmap fst - . withException ctx - $ findAndReadIface hsc_env - (text "mergeSignatures") im m NotBoot + . withIfaceErr ctx + $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces, -- thin it according to the export list, and do shaping on them. @@ -650,12 +636,12 @@ -- because we need module -- LocalSig (from the local -- export list) to match it! - is_mod = mod_name, + is_mod = mi_module ireq_iface, is_as = mod_name, is_qual = False, is_dloc = locA loc } ImpAll - rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) + rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1 setGblEnv tcg_env { tcg_rdr_env = rdr_env } $ exports_from_avail mb_exports rdr_env @@ -663,9 +649,9 @@ emptyImportAvails (tcg_semantic_mod tcg_env) case mb_r of - Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) + Just (_, as2, _) -> return (thinModIface as2 ireq_iface, as2) Nothing -> addMessages msgs >> failM - -- We can't think signatures from non signature packages + -- We can't thin signatures from non-signature packages _ -> return (ireq_iface, as1) -- 3(c). Only identifiers from signature packages are "ok" to -- import (that is, they are safe from a PVP perspective.) @@ -677,7 +663,7 @@ -- 3(d). Extend the name substitution (performing shaping) mb_r <- extend_ns nsubst as2 case mb_r of - Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) + Left err -> failWithTc (TcRnHsigShapeMismatch err) Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) @@ -688,9 +674,9 @@ <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) let thinned_ifaces = reverse rev_thinned_ifaces exports = nameShapeExports nsubst - rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env Nothing exports) _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) - warns = NoWarnings + warns = emptyWarn {- -- TODO: Warnings are transitive, but this is not what we want here: -- if a module reexports an entity from a signature, that should be OK. @@ -713,14 +699,14 @@ -- reexports are picked up correctly tcg_imports = tcg_imports orig_tcg_env, tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors exports), + tcg_dus = usesOnly (availsToNameSet exports), tcg_warns = warns } $ do tcg_env <- getGblEnv -- Make sure we didn't refer to anything that doesn't actually exist -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () - (mb_lies, _) <- exports_from_avail mb_exports rdr_env + (mb_lies, _, _) <- exports_from_avail mb_exports rdr_env (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) {- -- NB: This is commented out, because warns above is disabled. @@ -753,9 +739,9 @@ let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) + let fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] + , rdr_elt <- lookupGRE rdr_env (LookupOccName occ AllRelevantGREs) ] -- STEP 5: Typecheck the interfaces let type_env_var = tcg_type_env_var tcg_env @@ -890,11 +876,11 @@ n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) let dfun = setVarName (is_dfun inst) n return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) - tcg_env <- return tcg_env { - tcg_insts = map snd dfun_insts, - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) - } + tcg_env <- return $ + tcg_env { tcg_insts = map snd dfun_insts + , tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) } + addDependentFiles src_files return tcg_env @@ -927,19 +913,19 @@ logger = hsc_logger hsc_env exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . availNames) +exportOccs = concatMap (map nameOccName . availNames) impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc impl_msg unit_state impl_mod (Module req_uid req_mod_name) = pprWithUnitState unit_state $ - text "while checking that" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid + text "While checking that" <+> quotes (ppr impl_mod) <+> + text "implements signature" <+> quotes (ppr req_mod_name) <+> + text "in" <+> quotes (ppr req_uid) <> dot -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) -checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv +checkImplements :: HasDebugCallStack => Module -> InstantiatedModule -> TcRn TcGblEnv checkImplements impl_mod req_mod@(Module uid mod_name) = do hsc_env <- getTopEnv let unit_state = hsc_units hsc_env @@ -957,7 +943,7 @@ impl_iface <- initIfaceTcRn $ loadSysInterface (text "checkImplements 1") impl_mod let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) + (gresFromAvails hsc_env Nothing (mi_exports impl_iface)) nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) -- Load all the orphans, so the subsequent 'checkHsigIface' sees @@ -967,9 +953,9 @@ let avails = calculateAvails home_unit other_home_units impl_iface False{- safe -} NotBoot ImportedBySystem - fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) + fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] + , rdr_elt <- lookupGRE impl_gr (LookupOccName occ AllRelevantGREs) ] updGblEnv (\tcg_env -> tcg_env { -- Setting tcg_rdr_env to treat all exported entities from -- the implementing module as in scope improves error messages, @@ -996,18 +982,15 @@ isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err + Failed err -> + failWithTc $ TcRnInterfaceError $ + Can'tFindInterface err (LookingForSig isig_mod) -- STEP 3: Check that the implementing interface exports everything -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> - case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr occ) - <+> text "is exported by the hsig file, but not exported by the implementing module" - <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) + case lookupGRE impl_gr (LookupOccName occ SameNameSpace) of + [] -> addErr $ TcRnHsigMissingModuleExport occ unit_state impl_mod _ -> return () failIfErrsM diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs --- a/compiler/GHC/Tc/Utils/Concrete.hs +++ b/compiler/GHC/Tc/Utils/Concrete.hs @@ -8,9 +8,6 @@ ( -- * Ensuring that a type has a fixed runtime representation hasFixedRuntimeRep , hasFixedRuntimeRep_syntactic - - -- * Making a type concrete - , makeTypeConcrete ) where @@ -22,14 +19,15 @@ , mkGReflRightMCo, mkNomReflCo ) import GHC.Core.TyCo.Rep ( Type(..), MCoercion(..) ) import GHC.Core.TyCon ( isConcreteTyCon ) -import GHC.Core.Type ( isConcrete, typeKind, tyVarKind, coreView +import GHC.Core.Type ( isConcreteType, typeKind, tyVarKind, coreView , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy ) import GHC.Tc.Types ( TcM, ThStage(..), PendingStuff(..) ) import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) ) import GHC.Tc.Types.Evidence ( Role(..), TcCoercionN, TcMCoercionN ) import GHC.Tc.Types.Origin ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) ) -import GHC.Tc.Utils.Monad ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc ) +import GHC.Tc.Utils.Monad ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc + , liftZonkM ) import GHC.Tc.Utils.TcType ( TcType, TcKind, TcTypeFRR , MetaInfo(..), ConcreteTvOrigin(..) , isMetaTyVar, metaTyVarInfo, tcTyVarLevel ) @@ -37,9 +35,13 @@ , emitWantedEq ) import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.Name ( getOccName ) +import GHC.Types.Name.Occurrence( occNameFS ) import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable +import GHC.Data.FastString ( fsLit ) + import Control.Monad ( void ) import Data.Functor ( ($>) ) import Data.List.NonEmpty ( NonEmpty((:|)) ) @@ -83,7 +85,7 @@ Note [The Concrete mechanism] Instead of simply checking that a type `ty` is concrete (i.e. computing - 'isConcrete`), we emit an equality constraint: + 'isConcreteType`), we emit an equality constraint: co :: ty ~# concrete_ty @@ -179,7 +181,7 @@ - a concrete type constructor (as defined below), or - a concrete type variable (see Note [ConcreteTv] below), or - an application of a concrete type to another concrete type -GHC.Core.Type.isConcrete checks whether a type meets this definition. +GHC.Core.Type.isConcreteType checks whether a type meets this definition. Definition: a /concrete type constructor/ is defined by - a promoted data constructor @@ -495,7 +497,7 @@ -- Create a new ConcreteTv metavariable @concrete_tv@ -- and unify @ty ~# concrete_tv@. ; _ -> - do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) ki + do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) (fsLit "cx") ki -- NB: newConcreteTyVar asserts that 'ki' is concrete. ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } } where @@ -520,7 +522,8 @@ -> TcType -> TcM TcType ensureConcrete frr_orig ty - = do { (ty', errs) <- makeTypeConcrete conc_orig ty + = do { traceTc "ensureConcrete {" (ppr frr_orig $$ ppr ty) + ; (ty', errs) <- makeTypeConcrete conc_orig ty ; case errs of { err:errs -> do { traceTc "ensureConcrete } failure" $ @@ -623,8 +626,6 @@ -- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the -- type family application `F Int`. But we could decompose by setting -- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`. --- --- This would be useful in startSolvingByUnification. makeTypeConcrete conc_orig ty = do { res@(ty', _) <- runWriterT $ go ty ; traceTc "makeTypeConcrete" $ @@ -636,7 +637,7 @@ go ty | Just ty <- coreView ty = go ty - | isConcrete ty + | isConcreteType ty = pure ty go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above) = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv @@ -647,11 +648,14 @@ , TauTv <- metaTyVarInfo tv -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel do { kind <- go (tyVarKind tv) + ; let occ_fs = occNameFS (getOccName tv) + -- occ_fs: preserve the occurrence name of the original tyvar + -- This helps in error messages ; lift $ do { conc_tv <- setTcLevel (tcTyVarLevel tv) $ - newConcreteTyVar conc_orig kind + newConcreteTyVar conc_orig occ_fs kind ; let conc_ty = mkTyVarTy conc_tv - ; writeMetaTyVar tv conc_ty + ; liftZonkM $ writeMetaTyVar tv conc_ty ; return conc_ty } } | otherwise -- Don't attempt to make other type variables concrete 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 @@ -22,9 +22,10 @@ tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupRecSelParent, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, lookupGlobal_maybe, ioLookupDataCon, + lookupGlobal, lookupGlobal_maybe, addTypecheckedBinds, -- Local environment @@ -34,7 +35,6 @@ tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendBinderStack, tcExtendLocalTypeEnv, isTypeClosedLetBndr, - tcCheckUsage, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupIdMaybe, tcLookupTyVar, @@ -43,13 +43,10 @@ getInLocalScope, wrongThingErr, pprBinders, - tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, + tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, tcAddKindSigPlaceholders, getTypeSigNames, tcExtendRecEnv, -- For knot-tying - -- Tidying - tcInitTidyEnv, tcInitOpenTidyEnv, - -- Instances tcLookupInstance, tcGetInstEnvs, @@ -60,6 +57,7 @@ tcGetDefaultTys, -- Template Haskell stuff + StageCheckReason(..), checkWellStaged, tcMetaTy, thLevel, topIdLvl, isBrackStage, @@ -67,13 +65,14 @@ newDFunName, newFamInstTyConName, newFamInstAxiomName, mkStableIdFromString, mkStableIdFromName, - mkWrapperName + mkWrapperName, ) where import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.Env.KnotVars +import GHC.Driver.DynFlags import GHC.Builtin.Names import GHC.Builtin.Types @@ -87,15 +86,11 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper) -import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult ) -import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) +import GHC.Tc.Types.LclEnv -import GHC.Core.UsageEnv import GHC.Core.InstEnv -import GHC.Core.DataCon ( DataCon, flSelector ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.ConLike import GHC.Core.TyCon @@ -103,6 +98,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.Class + import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.External @@ -125,17 +121,17 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Env +import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader import GHC.Types.TyThing -import GHC.Types.Error +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt import Data.IORef -import Data.List (intercalate) +import Data.List ( intercalate ) import Control.Monad -import GHC.Driver.Env.KnotVars +import GHC.Iface.Errors.Types +import GHC.Types.Error {- ********************************************************************* * * @@ -151,10 +147,13 @@ mb_thing <- lookupGlobal_maybe hsc_env name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> pprPanic "lookupGlobal" msg + Failed err -> + let msg = case err of + Left name -> text "Could not find local name:" <+> ppr name + Right err -> pprDiagnostic err + in pprPanic "lookupGlobal" msg } - -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing) -- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. @@ -165,24 +164,26 @@ tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name - then (return - (Failed (text "Can't find local name: " <+> ppr name))) - -- Internal names can happen in GHCi - else - -- Try home package table and external package table - lookupImported_maybe hsc_env name + then return $ Failed $ Left name + -- Internal names can happen in GHCi + else do + res <- lookupImported_maybe hsc_env name + -- Try home package table and external package table + return $ case res of + Succeeded ok -> Succeeded ok + Failed err -> Failed (Right err) } -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name = do { mb_thing <- lookupType hsc_env name ; case mb_thing of Just thing -> return (Succeeded thing) Nothing -> importDecl_maybe hsc_env name - } + } -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) importDecl_maybe hsc_env name | Just thing <- wiredInNameTyThing_maybe name = do { when (needWiredInHomeIface thing) @@ -192,22 +193,6 @@ | otherwise = initIfaceLoad hsc_env (importDecl name) -ioLookupDataCon :: HscEnv -> Name -> IO DataCon -ioLookupDataCon hsc_env name = do - mb_thing <- ioLookupDataCon_maybe hsc_env name - case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupDataConIO" msg - -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon) -ioLookupDataCon_maybe hsc_env name = do - thing <- lookupGlobal hsc_env name - return $ case thing of - AConLike (RealDataCon con) -> Succeeded con - _ -> Failed $ - pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+> - text "used as a data constructor" - addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv addTypecheckedBinds tcg_env binds | isHsBootOrSig (tcg_src tcg_env) = tcg_env @@ -257,7 +242,7 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + Failed msg -> failWithTc (TcRnInterfaceError msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. @@ -274,42 +259,53 @@ thing <- tcLookupGlobal name case thing of AConLike (RealDataCon con) -> return con - _ -> wrongThingErr "data constructor" (AGlobal thing) name + _ -> wrongThingErr WrongThingDataCon (AGlobal thing) name tcLookupPatSyn :: Name -> TcM PatSyn tcLookupPatSyn name = do thing <- tcLookupGlobal name case thing of AConLike (PatSynCon ps) -> return ps - _ -> wrongThingErr "pattern synonym" (AGlobal thing) name + _ -> wrongThingErr WrongThingPatSyn (AGlobal thing) name tcLookupConLike :: Name -> TcM ConLike tcLookupConLike name = do thing <- tcLookupGlobal name case thing of AConLike cl -> return cl - _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name + _ -> wrongThingErr WrongThingConLike (AGlobal thing) name +tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent +tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons = cons }) + = case any_con of + PatSynName ps -> + RecSelPatSyn <$> tcLookupPatSyn ps + DataConName dc -> + RecSelData . dataConTyCon <$> tcLookupDataCon dc + where + any_con = head $ nonDetEltsUniqSet cons + -- Any constructor will give the same result here. + tcLookupClass :: Name -> TcM Class tcLookupClass name = do thing <- tcLookupGlobal name case thing of ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls - _ -> wrongThingErr "class" (AGlobal thing) name + _ -> wrongThingErr WrongThingClass (AGlobal thing) name tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name = do thing <- tcLookupGlobal name case thing of ATyCon tc -> return tc - _ -> wrongThingErr "type constructor" (AGlobal thing) name + _ -> wrongThingErr WrongThingTyCon (AGlobal thing) name tcLookupAxiom :: Name -> TcM (CoAxiom Branched) tcLookupAxiom name = do thing <- tcLookupGlobal name case thing of ACoAxiom ax -> return ax - _ -> wrongThingErr "axiom" (AGlobal thing) name + _ -> wrongThingErr WrongThingAxiom (AGlobal thing) name tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id tcLookupLocatedGlobalId = addLocMA tcLookupId @@ -326,17 +322,13 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs - ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> - failWithTc $ mkTcRnUnknownMessage - $ mkPlainError noHints (text "Couldn't match instance:" <+> err) - Right (inst, tys) - | uniqueTyVars tys -> return inst - | otherwise -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact) + ; let inst = lookupUniqueInstEnv instEnv cls tys >>= \ (inst, tys) -> + if uniqueTyVars tys then Right inst else Left LookupInstErrNotExact + ; case inst of + Right i -> return i + Left err -> failWithTc (TcRnLookupInstance cls tys err) } where - errNotExact = text "Not an exact match (i.e., some variables get instantiated)" - uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map getTyVar tys) @@ -460,7 +452,7 @@ local_env <- getLclTypeEnv case lookupNameEnv local_env name of Just thing -> return thing - Nothing -> (AGlobal <$> tcLookupGlobal name) + Nothing -> AGlobal <$> tcLookupGlobal name tcLookupTyVar :: Name -> TcM TcTyVar tcLookupTyVar name @@ -493,7 +485,7 @@ -- the same level as the lookup. Only used in one place... tcLookupLocalIds ns = do { env <- getLclEnv - ; return (map (lookup (tcl_env env)) ns) } + ; return (map (lookup (getLclEnvTypeEnv env)) ns) } where lookup lenv name = case lookupNameEnv lenv name of @@ -510,6 +502,7 @@ ATcTyCon tc -> return tc _ -> pprPanic "tcLookupTcTyCon" (ppr name) + getInLocalScope :: TcM (Name -> Bool) getInLocalScope = do { lcl_env <- getLclTypeEnv ; return (`elemNameEnv` lcl_env) } @@ -520,7 +513,7 @@ -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr tcExtendKindEnvList things thing_inside = do { traceTc "tcExtendKindEnvList" (ppr things) - ; updLclEnv upd_env thing_inside } + ; updLclCtxt upd_env thing_inside } where upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } @@ -528,7 +521,7 @@ -- A variant of tcExtendKindEvnList tcExtendKindEnv extra_env thing_inside = do { traceTc "tcExtendKindEnv" (ppr extra_env) - ; updLclEnv upd_env thing_inside } + ; updLclCtxt upd_env thing_inside } where upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } @@ -639,9 +632,9 @@ -- that are bound together with extra_env and should not be regarded -- as free in the types of extra_env. = do { traceTc "tc_extend_local_env" (ppr extra_env) - ; updLclEnv upd_lcl_env thing_inside } + ; updLclCtxt upd_lcl_env thing_inside } where - upd_lcl_env env0@(TcLclEnv { tcl_th_ctxt = stage + upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = stage , tcl_rdr = rdr_env , tcl_th_bndrs = th_bndrs , tcl_env = lcl_type_env }) @@ -662,63 +655,10 @@ thlvl = (top_lvl, thLevel stage) -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv -tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things +tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt +tcExtendLocalTypeEnv tc_ty_things lcl_env@(TcLclCtxt { tcl_env = lcl_type_env }) = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } --- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the --- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the --- usage environment. See also Note [Wrapper returned from tcSubMult] in --- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function. -tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper) -tcCheckUsage name id_mult thing_inside - = do { (local_usage, result) <- tcCollectingUsage thing_inside - ; wrapper <- check_then_add_usage local_usage - ; return (result, wrapper) } - where - check_then_add_usage :: UsageEnv -> TcM HsWrapper - -- Checks that the usage of the newly introduced binder is compatible with - -- its multiplicity, and combines the usage of non-new binders to |uenv| - check_then_add_usage uenv - = do { let actual_u = lookupUE uenv name - ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) - ; wrapper <- case actual_u of - Bottom -> return idHsWrapper - Zero -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult - MUsage m -> do { m <- promote_mult m - ; tcSubMult (UsageEnvironmentOf name) m id_mult } - ; tcEmitBindingUsage (deleteUE uenv name) - ; return wrapper } - - -- This is gross. The problem is in test case typecheck/should_compile/T18998: - -- f :: a %1-> Id n a -> Id n a - -- f x (MkId _) = MkId x - -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors - -- invents a new multiplicity variable p[2] for the application MkId x. This - -- variable is at level 2, bumped because of the GADT pattern-match (MkId _). - -- We eventually unify the variable with One, due to the call to tcSubMult in - -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check - -- fails. - -- - -- What to do? If we did inference "for real", the sub-multiplicity constraint - -- would end up in the implication of the GADT pattern-match, and all would - -- be well. But we don't have a real sub-multiplicity constraint to put in - -- the implication. (Multiplicity inference works outside the usual generate- - -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we - -- must promote all multiplicity variables to reflect this outer TcLevel. - -- It's reminiscent of floating a constraint, really, so promotion is - -- appropriate. The promoteTcType function works only on types of kind TYPE rr, - -- so we can't use it here. Thus, this dirtiness. - -- - -- It works nicely in practice. - -- - -- We use a set to avoid calling promoteMetaTyVarTo twice on the same - -- metavariable. This happened in #19400. - promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m) - ; any_promoted <- promoteTyVarSet fvs - ; if any_promoted then zonkTcType m else return m - } - {- ********************************************************************* * * The TcBinderStack @@ -728,42 +668,9 @@ tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a tcExtendBinderStack bndrs thing_inside = do { traceTc "tcExtendBinderStack" (ppr bndrs) - ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + ; updLclCtxt (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) thing_inside } -tcInitTidyEnv :: TcM TidyEnv --- We initialise the "tidy-env", used for tidying types before printing, --- by building a reverse map from the in-scope type variables to the --- OccName that the programmer originally used for them -tcInitTidyEnv - = do { lcl_env <- getLclEnv - ; go emptyTidyEnv (tcl_bndrs lcl_env) } - where - go (env, subst) [] - = return (env, subst) - go (env, subst) (b : bs) - | TcTvBndr name tyvar <- b - = do { let (env', occ') = tidyOccName env (nameOccName name) - name' = tidyNameOcc name occ' - tyvar1 = setTyVarName tyvar name' - ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 - -- Be sure to zonk here! Tidying applies to zonked - -- types, so if we don't zonk we may create an - -- ill-kinded type (#14175) - ; go (env', extendVarEnv subst tyvar tyvar2) bs } - | otherwise - = go (env, subst) bs - --- | Get a 'TidyEnv' that includes mappings for all vars free in the given --- type. Useful when tidying open types. -tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv -tcInitOpenTidyEnv tvs - = do { env1 <- tcInitTidyEnv - ; let env2 = tidyFreeTyCoVars env1 tvs - ; return env2 } - - - {- ********************************************************************* * * Adding placeholders @@ -798,6 +705,12 @@ | PSB{ psb_id = L _ name } <- pat_syns ] thing_inside +tcAddKindSigPlaceholders :: LHsKind GhcRn -> TcM a -> TcM a +tcAddKindSigPlaceholders kind_sig thing_inside + = tcExtendKindEnvList [ (name, APromotionErr TypeVariablePE) + | name <- hsScopedKvs kind_sig ] + thing_inside + getTypeSigNames :: [LSig GhcRn] -> NameSet -- Get the names that have a user type sig getTypeSigNames sigs @@ -886,7 +799,7 @@ ************************************************************************ -} -checkWellStaged :: SDoc -- What the stage check is for +checkWellStaged :: StageCheckReason -- What the stage check is for -> ThLevel -- Binding level (increases inside brackets) -> ThLevel -- Use stage -> TcM () -- Fail if badly staged, adding an error @@ -895,22 +808,11 @@ = return () -- E.g. \x -> [| $(f x) |] | bind_lvl == outerLevel -- GHC restriction on top level splices - = stageRestrictionError pp_thing + = failWithTc (TcRnStageRestriction pp_thing) | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Stage error:" <+> pp_thing <+> - hsep [text "is bound at stage" <+> ppr bind_lvl, - text "but used at stage" <+> ppr use_lvl] - -stageRestrictionError :: SDoc -> TcM a -stageRestrictionError pp_thing - = failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [ text "GHC stage restriction:" - , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," - , text "and must be imported, not defined locally"])] + TcRnBadlyStaged pp_thing bind_lvl use_lvl topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -1077,7 +979,7 @@ = do { is_boot <- tcIsHsBootOrSig ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys + concatMap (occNameString . getDFunTyKey) tys ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } @@ -1168,17 +1070,14 @@ notFound :: Name -> TcM TyThing notFound name = do { lcl_env <- getLclEnv - ; let stage = tcl_th_ctxt lcl_env + ; let stage = getLclEnvThStage lcl_env ; case stage of -- See Note [Out of scope might be a staging error] Splice {} | isUnboundName name -> failM -- If the name really isn't in scope -- don't report it again (#11941) - | otherwise -> stageRestrictionError (quotes (ppr name)) + | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name)) _ -> failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat[text "GHC internal error:" <+> quotes (ppr name) <+> - text "is not in scope during type checking, but it passed the renamer", - text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] + mkTcRnNotInScope (getRdrName name) (NotInScopeTc (getLclEnvTypeEnv lcl_env)) -- Take care: printing the whole gbl env can -- cause an infinite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; @@ -1186,12 +1085,9 @@ -- very unhelpful, because it hides one compiler bug with another } -wrongThingErr :: String -> TcTyThing -> Name -> TcM a -wrongThingErr expected thing name - = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) - in failWithTc msg +wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a +wrongThingErr expected thing name = + failWithTc (TcRnTyThingUsedWrong expected thing name) {- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/Env.hs-boot b/compiler/GHC/Tc/Utils/Env.hs-boot deleted file mode 100644 --- a/compiler/GHC/Tc/Utils/Env.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module GHC.Tc.Utils.Env where - -import GHC.Tc.Types( TcM ) -import GHC.Types.Var.Env( TidyEnv ) - --- Annoyingly, there's a recursion between tcInitTidyEnv --- (which does zonking and hence needs GHC.Tc.Utils.TcMType) and --- addErrTc etc which live in GHC.Tc.Utils.Monad. Rats. -tcInitTidyEnv :: TcM TidyEnv - 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts, RecursiveDo #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -27,7 +28,7 @@ newOverloadedLit, mkOverLit, - newClsInst, + newClsInst, newFamInst, tcGetInsts, tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, @@ -43,25 +44,24 @@ import GHC.Driver.Session import GHC.Driver.Env -import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) +import GHC.Builtin.Types ( heqDataCon, integerTyConName ) import GHC.Builtin.Names import GHC.Hs import GHC.Hs.Syn.Type ( hsLitType ) import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import GHC.Core.Predicate import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor import GHC.Core.Type -import GHC.Core.Multiplicity -import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Core.Class( Class ) import GHC.Core.DataCon +import GHC.Core.Coercion.Axiom import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) -import GHC.Tc.Utils.Zonk +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin @@ -72,6 +72,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Types.Id.Make( mkDictFunId ) import GHC.Types.Basic ( TypeOrKind(..), Arity ) @@ -89,7 +90,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable -import GHC.Utils.Unique (sameUnique) import GHC.Unit.State import GHC.Unit.External @@ -102,7 +102,7 @@ {- ************************************************************************ * * - Creating and emittind constraints + Creating and emitting constraints * * ************************************************************************ -} @@ -387,71 +387,21 @@ go n subst kind | n > 0 - , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisiblePiTyBinder bndr - = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr + , Just (bndr, body) <- tcSplitForAllTyVarBinder_maybe kind + , isInvisibleForAllTyFlag (binderFlag bndr) + = do { (subst', arg) <- tcInstInvisibleTyBinder subst (binderVar bndr) ; (args, inner_ty) <- go (n-1) subst' body ; return (arg:args, inner_ty) } | otherwise = return ([], substTy subst kind) -tcInstInvisibleTyBinder :: Subst -> PiTyVarBinder -> TcM (Subst, TcType) +tcInstInvisibleTyBinder :: Subst -> TyVar -> TcM (Subst, TcType) -- Called only to instantiate kinds, in user-written type signatures -tcInstInvisibleTyBinder subst (Named (Bndr tv _)) +tcInstInvisibleTyBinder subst tv = do { (subst', tv') <- newMetaTyVarX subst tv ; return (subst', mkTyVarTy tv') } -tcInstInvisibleTyBinder subst (Anon ty af) - | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) - -- For kinds like (k1 ~ k2) => blah, we want to emit a unification - -- constraint for (k1 ~# k2) and return the argument (Eq# k1 k2) - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - -- Equality is the *only* constraint currently handled in types. - = assert (isInvisibleFunArg af) $ - do { co <- unifyKind Nothing k1 k2 - ; return (subst, mk co) } - - | otherwise -- This should never happen - -- See GHC.Core.TyCo.Rep Note [Constraints in kinds] - = pprPanic "tcInvisibleTyBinder" (ppr ty) - -------------------------------- -get_eq_tys_maybe :: Type - -> Maybe ( Coercion -> Type - -- Given a coercion proving t1 ~# t2, produce the - -- right instantiation for the PiTyVarBinder at hand - , Type -- t1 - , Type -- t2 - ) --- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep -get_eq_tys_maybe ty - -- Lifted heterogeneous equality (~~) - | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` heqTyConKey - = Just (mkHEqBoxTy k1 k2, k1, k2) - - -- Lifted homogeneous equality (~) - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` eqTyConKey - = Just (mkEqBoxTy k1 k2, k1, k2) - - | otherwise - = Nothing - --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: Type -> Type -> TcCoercion -> Type -mkHEqBoxTy ty1 ty2 co - = mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = typeKind ty1 - k2 = typeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: Type -> Type -> TcCoercion -> Type -mkEqBoxTy ty1 ty2 co - = mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = typeKind ty1 - {- ********************************************************************* * * SkolemTvs (immutable) @@ -813,7 +763,7 @@ return (std_nm, unLoc expr) syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv - -> TcRn (TidyEnv, SDoc) + -> ZonkM (TidyEnv, SDoc) syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg) where msg = vcat [ text "When checking that" <+> quotes (ppr name) @@ -842,17 +792,17 @@ in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty mb_arity :: Maybe Arity mb_arity -- arity of the arrow operation, counting type-level arguments - | sameUnique std_nm arrAName -- result used as an argument in, e.g., do_premap + | std_nm == arrAName -- result used as an argument in, e.g., do_premap = Just 3 - | sameUnique std_nm composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt = Just 5 - | sameUnique std_nm firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + | std_nm == firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt = Just 4 - | sameUnique std_nm appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp + | std_nm == appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp = Just 2 - | sameUnique std_nm choiceAName -- result used as an argument in, e.g., HsCmdIf + | std_nm == choiceAName -- result used as an argument in, e.g., HsCmdIf = Just 5 - | sameUnique std_nm loopAName -- result used as an argument in, e.g., HsCmdIf + | std_nm == loopAName -- result used as an argument in, e.g., HsCmdIf = Just 4 | otherwise = Nothing @@ -860,7 +810,7 @@ {- ************************************************************************ * * - Instances + Class instances * * ************************************************************************ -} @@ -871,17 +821,32 @@ -- set the OverlapMode to 'm' getOverlapFlag overlap_mode = do { dflags <- getDynFlags - ; let overlap_ok = xopt LangExt.OverlappingInstances dflags - incoherent_ok = xopt LangExt.IncoherentInstances dflags + ; let overlap_ok = xopt LangExt.OverlappingInstances dflags + incoherent_ok = xopt LangExt.IncoherentInstances dflags + noncanonical_incoherence = not $ gopt Opt_SpecialiseIncoherents dflags + use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags , overlapMode = x } default_oflag | incoherent_ok = use (Incoherent NoSourceText) | overlap_ok = use (Overlaps NoSourceText) | otherwise = use (NoOverlap NoSourceText) - final_oflag = setOverlapModeMaybe default_oflag overlap_mode + oflag = setOverlapModeMaybe default_oflag overlap_mode + final_oflag = effective_oflag noncanonical_incoherence oflag ; return final_oflag } + where + effective_oflag noncanonical_incoherence oflag@OverlapFlag{ overlapMode = overlap_mode } + = oflag { overlapMode = effective_overlap_mode noncanonical_incoherence overlap_mode } + -- The `-fspecialise-incoherents` flag controls the meaning of the + -- `Incoherent` overlap mode: as either an Incoherent overlap + -- flag, or a NonCanonical overlap flag. See Note [Coherence and specialisation: overview] + -- in GHC.Core.InstEnv for why we care about this distinction. + effective_overlap_mode noncanonical_incoherence = \case + Incoherent s | noncanonical_incoherence -> NonCanonical s + overlap_mode -> overlap_mode + + tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. tcGetInsts = fmap tcg_insts getGblEnv @@ -902,11 +867,13 @@ -- helpful to use the same names ; oflag <- getOverlapFlag overlap_mode - ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; when (isOrphan (is_orphan inst)) $ - addDiagnostic (TcRnOrphanInstance inst) - ; return inst } + ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys' + ; when (isOrphan (is_orphan cls_inst)) $ + addDiagnostic (TcRnOrphanInstance $ Left cls_inst) + + ; return cls_inst } + tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside @@ -968,9 +935,9 @@ ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } -{- -Note [Signature files and type class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +{- Note [Signature files and type class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Instances in signature files do not have an effect when compiling: when you compile a signature against an implementation, you will see the instances WHETHER OR NOT the instance is declared in @@ -1016,10 +983,41 @@ ************************************************************************ * * - Errors and tracing + Family instances * * ************************************************************************ -} + +-- All type variables in a FamInst must be fresh. This function +-- creates the fresh variables and applies the necessary substitution +-- It is defined here to avoid a dependency from FamInstEnv on the monad +-- code. + +newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst +-- Freshen the type variables of the FamInst branches +newFamInst flavor axiom + | CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomSingleBranch axiom + = do { -- Freshen the type variables + (subst, tvs') <- freshenTyVarBndrs tvs + ; (subst, cvs') <- freshenCoVarBndrsX subst cvs + ; let lhs' = substTys subst lhs + rhs' = substTy subst rhs + + ; let fam_inst = mkLocalFamInst flavor axiom tvs' cvs' lhs' rhs' + ; when (isOrphan (fi_orphan fam_inst)) $ + addDiagnostic (TcRnOrphanInstance $ Right fam_inst) + + ; return fam_inst } + + +{- ********************************************************************* +* * + Errors and tracing +* * +********************************************************************* -} traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs 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 @@ -2,6 +2,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -19,7 +20,7 @@ -- * Simple accessors discardResult, getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv, + setGblEnv, getLclEnv, updLclEnv, updLclCtxt, setLclEnv, restoreLclEnv, updTopFlags, getEnvs, setEnvs, updEnvs, restoreEnvs, xoptM, doptM, goptM, woptM, @@ -41,7 +42,7 @@ newSysName, newSysLocalId, newSysLocalIds, -- * Accessing input/output - newTcRef, readTcRef, writeTcRef, updTcRef, + newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM, -- * Debugging traceTc, traceRn, traceOptTcRn, dumpOptTcRn, @@ -53,21 +54,22 @@ -- * Typechecker global environment getIsGHCi, getGHCiMonad, getInteractivePrintName, - tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, + tcHscSource, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, + getFixityEnv, extendFixityEnv, getDeclaredDefaultTys, addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, + inGeneratedCode, setInGeneratedCode, wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, failWith, failAt, addErrAt, addErrs, - checkErr, + checkErr, checkErrAt, addMessages, discardWarnings, mkDetailedMessage, @@ -83,7 +85,7 @@ -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, + addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) addErrTc, @@ -104,7 +106,7 @@ chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, emitInsoluble, + emitImplication, emitImplications, emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError, discardConstraints, captureConstraints, tryCaptureConstraints, pushLevelAndCaptureConstraints, @@ -138,11 +140,14 @@ forkM, setImplicitEnvM, - withException, + withException, withIfaceErr, -- * Stuff for cost centres. getCCIndexM, getCCIndexTcM, + -- * Zonking + liftZonkM, + -- * Types etc. module GHC.Tc.Types, module GHC.Data.IOEnv @@ -153,11 +158,14 @@ import GHC.Builtin.Names +import GHC.Tc.Errors.Types import GHC.Tc.Types -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin +import GHC.Tc.Types.TcRef import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.TcType import GHC.Hs hiding (LIE) @@ -215,13 +223,13 @@ import Data.IORef import Control.Monad -import GHC.Tc.Errors.Types -import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) - import qualified Data.Map as Map import GHC.Driver.Env.KnotVars import GHC.Linker.Types import GHC.Types.Unique.DFM +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr +import GHC.Tc.Types.LclEnv {- ************************************************************************ @@ -300,7 +308,6 @@ tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, tcg_default = if moduleUnit mod == primUnit || moduleUnit mod == bignumUnit then Just [] -- See Note [Default types] @@ -332,7 +339,7 @@ tcg_sigs = emptyNameSet, tcg_ksigs = emptyNameSet, tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, + tcg_warns = emptyWarn, tcg_anns = [], tcg_tcs = [], tcg_insts = [], @@ -377,7 +384,7 @@ ; errs_var <- newIORef emptyMessages ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { - tcl_errs = errs_var, + tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! tcl_in_gen_code = False, @@ -387,10 +394,12 @@ tcl_th_bndrs = emptyNameEnv, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, - tcl_usage = usage_var, tcl_bndrs = [], - tcl_lie = lie_var, tcl_tclvl = topTcLevel + }, + tcl_usage = usage_var, + tcl_lie = lie_var, + tcl_errs = errs_var } ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ @@ -445,14 +454,14 @@ ************************************************************************ -} -initTcRnIf :: Char -- ^ Tag for unique supply +initTcRnIf :: Char -- ^ Mask for unique supply -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a -initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside +initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside = do { let { env = Env { env_top = hsc_env, - env_ut = uniq_tag, + env_um = uniq_mask, env_gbl = gbl_env, env_lcl = lcl_env} } @@ -494,6 +503,8 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> env { env_lcl = upd lcl }) +updLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a +updLclCtxt upd = updLclEnv (modifyLclCtxt upd) setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) @@ -662,6 +673,16 @@ Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err)) Succeeded result -> return result +withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a +withIfaceErr ctx do_this = do + r <- do_this + case r of + Failed err -> do + let opts = defaultDiagnosticOpts @IfaceMessage + msg = missingInterfaceErrorDiagnostic opts err + liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg)) + Succeeded result -> return result + {- ************************************************************************ * * @@ -672,17 +693,18 @@ newArrowScope :: TcM a -> TcM a newArrowScope - = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } + = updLclEnv $ \env -> + modifyLclCtxt (\ctx -> ctx { tcl_arrow_ctxt = ArrowCtxt (getLclEnvRdrEnv env) (tcl_lie env) } ) env -- Return to the stored environment (from the enclosing proc) escapeArrowScope :: TcM a -> TcM a escapeArrowScope = updLclEnv $ \ env -> - case tcl_arrow_ctxt env of + case getLclEnvArrowCtxt env of NoArrowCtxt -> env - ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt - , tcl_lie = lie - , tcl_rdr = rdr_env } + ArrowCtxt rdr_env lie -> env { tcl_lcl_ctxt = (tcl_lcl_ctxt env) { tcl_arrow_ctxt = NoArrowCtxt + , tcl_rdr = rdr_env } + , tcl_lie = lie } {- ************************************************************************ @@ -695,14 +717,14 @@ newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv - ; let tag = env_ut env - ; liftIO $! uniqFromTag tag } + ; let mask = env_um env + ; liftIO $! uniqFromMask mask } newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv - ; let tag = env_ut env - ; liftIO $! mkSplitUniqSupply tag } + ; let mask = env_um env + ; liftIO $! mkSplitUniqSupply mask } cloneLocalName :: Name -> TcM Name -- Make a fresh Internal name with the same OccName and SrcSpan @@ -729,9 +751,9 @@ newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys - = do { us <- newUniqueSupply + = do { us <- getUniquesM ; let mkId' n (Scaled w t) = mkSysLocal fs n w t - ; return (zipWith mkId' (uniqsFromSupply us) tys) } + ; return (zipWith mkId' us tys) } instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique @@ -740,27 +762,6 @@ {- ************************************************************************ * * - Accessing input/output -* * -************************************************************************ --} - -newTcRef :: a -> TcRnIf gbl lcl (TcRef a) -newTcRef = newMutVar - -readTcRef :: TcRef a -> TcRnIf gbl lcl a -readTcRef = readMutVar - -writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () -writeTcRef = writeMutVar - -updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () --- Returns () -updTcRef ref fn = liftIO $ modifyIORef' ref fn - -{- -************************************************************************ -* * Debugging * * ************************************************************************ @@ -917,8 +918,11 @@ getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } tcIsHsBootOrSig :: TcRn Bool -tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } +tcIsHsBootOrSig = isHsBootOrSig <$> tcHscSource +tcHscSource :: TcRn HscSource +tcHscSource = do { env <- getGblEnv; return (tcg_src env)} + tcIsHsig :: TcRn Bool tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } @@ -929,7 +933,7 @@ getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) -getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, getLclEnvRdrEnv lcl) } getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } @@ -942,9 +946,6 @@ = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getRecFieldEnv :: TcRn RecFieldEnv -getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } - getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } @@ -964,26 +965,33 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) } +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) } -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool -inGeneratedCode = tcl_in_gen_code <$> getLclEnv +inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] -- for the tcl_in_gen_code manipulation setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) thing_inside setSrcSpan loc@(UnhelpfulSpan _) thing_inside | isGeneratedSrcSpan loc - = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside + = setInGeneratedCode thing_inside | otherwise = thing_inside +-- | Mark the inner computation as being done inside generated code. +-- +-- See Note [Error contexts in generated code] +setInGeneratedCode :: TcRn a -> TcRn a +setInGeneratedCode thing_inside = + updLclCtxt (\env -> env { tcl_in_gen_code = True }) thing_inside + setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) @@ -1066,7 +1074,7 @@ -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt - ; tidy_env <- tcInitTidyEnv + ; tidy_env <- liftZonkM $ tcInitTidyEnv ; err_info <- mkErrInfo tidy_env ctxt ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg ; add_long_err_at loc detailed_msg } @@ -1084,6 +1092,9 @@ -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) +checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcRn () +checkErrAt loc ok msg = unless ok (addErrAt loc msg) + addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar @@ -1201,23 +1212,25 @@ Note [Error contexts in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, +* setSrcSpan sets tcl_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, and back to False when we get a useful SrcSpan -* When tc_in_gen_code is True, addErrCtxt becomes a no-op. +* When tcl_in_gen_code is True, addErrCtxt becomes a no-op. So typically it's better to do setSrcSpan /before/ addErrCtxt. See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for -more discussion of this fancy footwork. +more discussion of this fancy footwork, as well as +Note [Generated code and pattern-match checking] in GHC.Types.Basic for the +relation with pattern-match checks. -} getErrCtxt :: TcM [ErrCtxt] -getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } +getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a {-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] -setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) +setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | Add a fixed message to the error context. This message should not -- do any tidying. @@ -1226,7 +1239,7 @@ addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] addErrCtxtM ctxt = pushCtxt (False, ctxt) @@ -1240,7 +1253,7 @@ -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a +addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) @@ -1251,13 +1264,12 @@ updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -- Do not update the context if we are in generated code -- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr -updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen }) - | in_gen = env - | otherwise = env { tcl_ctxt = ctxt : ctxts } +updCtxt ctxt env + | lclEnvInGeneratedCode env = env + | otherwise = addLclEnvErrCtxt ctxt env popErrCtxt :: TcM a -> TcM a -popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = pop ctxt }) +popErrCtxt = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) where pop [] = [] pop (_:msgs) = msgs @@ -1266,17 +1278,27 @@ getCtLocM origin t_or_k = do { env <- getLclEnv ; return (CtLoc { ctl_origin = origin - , ctl_env = env + , ctl_env = mkCtLocEnv env , ctl_t_or_k = t_or_k , ctl_depth = initialSubGoalDepth }) } +mkCtLocEnv :: TcLclEnv -> CtLocEnv +mkCtLocEnv lcl_env = + CtLocEnv { ctl_bndrs = getLclEnvBinderStack lcl_env + , ctl_ctxt = getLclEnvErrCtxt lcl_env + , ctl_loc = getLclEnvLoc lcl_env + , ctl_tclvl = getLclEnvTcLevel lcl_env + , ctl_in_gen_code = lclEnvInGeneratedCode lcl_env + , ctl_rdr = getLclEnvRdrEnv lcl_env + } + setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc setCtLocM (CtLoc { ctl_env = lcl }) thing_inside - = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl - , tcl_bndrs = tcl_bndrs lcl - , tcl_ctxt = tcl_ctxt lcl }) - thing_inside + = updLclEnv (\env -> setLclEnvLoc (ctl_loc lcl) + $ setLclEnvErrCtxt (ctl_ctxt lcl) + $ setLclEnvBinderStack (ctl_bndrs lcl) + $ env) thing_inside {- ********************************************************************* @@ -1315,7 +1337,7 @@ capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the --- errors arnd warnings generated by thing_inside +-- errors and warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! -- Reason for precondition: an exception would blow past the place -- where we read the msg_var, and we'd lose the constraints altogether @@ -1534,8 +1556,19 @@ tidy up the message; we then use it to tidy the context messages -} +{- + +Note [Reporting warning diagnostics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use functions below to report warnings. For the most part, +we do /not/ need to check any warning flags before doing so. +See https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values +for the design. + +-} + addErrTc :: TcRnMessage -> TcM () -addErrTc err_msg = do { env0 <- tcInitTidyEnv +addErrTc err_msg = do { env0 <- liftZonkM tcInitTidyEnv ; addErrTcM (env0, err_msg) } addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () @@ -1597,8 +1630,8 @@ -- | Display a diagnostic in the current context. addDiagnosticTc :: TcRnMessage -> TcM () addDiagnosticTc msg - = do { env0 <- tcInitTidyEnv ; - addDiagnosticTcM (env0, msg) } + = do { env0 <- liftZonkM tcInitTidyEnv + ; addDiagnosticTcM (env0, msg) } -- | Display a diagnostic in a given context. addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () @@ -1616,7 +1649,7 @@ loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx !diag_opts <- initDiagOpts <$> getDynFlags - env0 <- tcInitTidyEnv + env0 <- liftZonkM tcInitTidyEnv ctxt <- getErrCtxt err_info <- mkErrInfo env0 ctxt reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty))) @@ -1674,7 +1707,7 @@ go _ _ _ [] = return empty go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg - = do { (env', msg) <- ctxt env + = do { (env', msg) <- liftZonkM $ ctxt env ; let n' = if is_landmark then n else n+1 ; rest <- go dbg n' env' ctxts ; return (msg $$ rest) } @@ -1816,12 +1849,6 @@ do { lie_var <- getConstraintVar ; updTcRef lie_var (`addImplics` ct) } -emitInsoluble :: Ct -> TcM () -emitInsoluble ct - = do { traceTc "emitInsoluble" (ppr ct) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` unitBag ct) } - emitDelayedErrors :: Bag DelayedError -> TcM () emitDelayedErrors errs = do { traceTc "emitDelayedErrors" (ppr errs) @@ -1856,29 +1883,29 @@ = do { tclvl <- getTcLevel ; let tclvl' = pushTcLevel tclvl ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') - ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $ + ; (res, lie) <- updLclEnv (setLclEnvTcLevel tclvl') $ captureConstraints thing_inside ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') ; return (tclvl', lie, res) } pushTcLevelM_ :: TcM a -> TcM a -pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x +pushTcLevelM_ = updLclEnv (modifyLclEnvTcLevel pushTcLevel) pushTcLevelM :: TcM a -> TcM (TcLevel, a) -- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType pushTcLevelM thing_inside = do { tclvl <- getTcLevel ; let tclvl' = pushTcLevel tclvl - ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside + ; res <- updLclEnv (setLclEnvTcLevel tclvl') thing_inside ; return (tclvl', res) } getTcLevel :: TcM TcLevel getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } + ; return $! getLclEnvTcLevel env } setTcLevel :: TcLevel -> TcM a -> TcM a setTcLevel tclvl thing_inside - = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside + = updLclEnv (setLclEnvTcLevel tclvl) thing_inside isTouchableTcM :: TcTyVar -> TcM Bool isTouchableTcM tv @@ -1886,15 +1913,13 @@ ; return (isTouchableMetaTyVar lvl tv) } getLclTypeEnv :: TcM TcTypeEnv -getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } +getLclTypeEnv = do { env <- getLclEnv; return (getLclEnvTypeEnv env) } setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a -- Set the local type envt, but do *not* disturb other fields, -- notably the lie_var setLclTypeEnv lcl_env thing_inside - = updLclEnv upd thing_inside - where - upd env = env { tcl_env = tcl_env lcl_env } + = updLclEnv (setLclEnvTypeEnv (getLclEnvTypeEnv lcl_env)) thing_inside traceTcConstraints :: String -> TcM () traceTcConstraints msg @@ -2042,17 +2067,17 @@ ; updTcRef (tcg_keep env) (`extendNameSet` name) } getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } +getStage = do { env <- getLclEnv; return (getLclEnvThStage env) } getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) getStageAndBindLevel name = do { env <- getLclEnv; - ; case lookupNameEnv (tcl_th_bndrs env) name of + ; case lookupNameEnv (getLclEnvThBndrs env) name of Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } + Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, getLclEnvThStage env)) } setStage :: ThStage -> TcM a -> TcRn a -setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) +setStage s = updLclEnv (setLclEnvThStage s) -- | Adds the given modFinalizers to the global environment and set them to use -- the current local environment. @@ -2104,11 +2129,11 @@ -} getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } +getLocalRdrEnv = do { env <- getLclEnv; return (getLclEnvRdrEnv env) } setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside + = updLclEnv (setLclEnvRdrEnv rdr_env) thing_inside {- ************************************************************************ @@ -2281,3 +2306,22 @@ -- | See 'getCCIndexM'. getCCIndexTcM :: FastString -> TcM CostCentreIndex getCCIndexTcM = getCCIndexM tcg_cc_st + +-------------------------------------------------------------------------------- + +-- | Lift a computation from the dedicated zonking monad 'ZonkM' to the +-- full-fledged 'TcM' monad. +liftZonkM :: ZonkM a -> TcM a +liftZonkM (ZonkM f) = + do { logger <- getLogger + ; name_ppr_ctx <- getNamePprCtx + ; lvl <- getTcLevel + ; src_span <- getSrcSpanM + ; bndrs <- getLclEnvBinderStack <$> getLclEnv + ; let zge = ZonkGblEnv { zge_logger = logger + , zge_name_ppr_ctx = name_ppr_ctx + , zge_src_span = src_span + , zge_tc_level = lvl + , zge_binder_stack = bndrs } + ; liftIO $ f zge } +{-# INLINE liftZonkM #-} 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 @@ -24,2817 +24,2346 @@ newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, newOpenBoxedTypeKind, - newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, - newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar, - newCycleBreakerTyVar, - - newMultiplicityVar, - readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, - - -------------------------------- - -- Creating new evidence variables - newEvVar, newEvVars, newDict, - newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - emitWantedEqs, - newTcEvBinds, newNoTcEvBinds, addTcEvBind, - emitNewExprHole, - - newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, - checkCoercionHole, - - ConcreteHole, newConcreteHole, - - newImplication, - - -------------------------------- - -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, - newMetaTyVarTyVarX, - newTyVarTyVar, cloneTyVarTyVar, - newPatSigTyVar, newSkolemTyVar, newWildCardX, - - -------------------------------- - -- Expected types - ExpType(..), ExpSigmaType, ExpRhoType, - mkCheckExpType, newInferExpType, newInferExpTypeFRR, - tcInfer, tcInferFRR, - readExpType, readExpType_maybe, readScaledExpType, - expTypeToType, scaledExpTypeToType, - checkingExpType_maybe, checkingExpType, - inferResultToType, ensureMonoType, promoteTcType, - - -------------------------------- - -- Zonking and tidying - zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins, - zonkTidyFRRInfos, - tidyEvVar, tidyCt, tidyHole, tidyDelayedError, - zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars, - zonkInvisTVBinder, - zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, - zonkTyCoVarsAndFVList, - - zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, - zonkEvVar, zonkWC, zonkImplication, zonkSimples, - zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon, - - --------------------------------- - -- Promotion, defaulting, skolemisation - defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, - quantifyTyVars, isQuantifiableTv, - zonkAndSkolemise, skolemiseQuantifiedTyVar, - doNotQuantifyTyVars, - - candidateQTyVarsOfType, candidateQTyVarsOfKind, - candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, - candidateQTyVarsWithBinders, - CandidatesQTvs(..), delCandidates, - candidateKindVars, partitionCandidates, - - ------------------------------ - -- Representation polymorphism - checkTypeHasFixedRuntimeRep, - - ------------------------------ - -- Other - anyUnfilledCoercionHoles - ) where - -import GHC.Prelude - -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Monad -- TcType, amongst others -import GHC.Tc.Utils.TcType -import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Class -import GHC.Core.Predicate -import GHC.Core.InstEnv (ClsInst(is_tys)) - -import GHC.Types.Var -import GHC.Types.Id as Id -import GHC.Types.Name -import GHC.Types.Var.Set - -import GHC.Builtin.Types -import GHC.Types.Error -import GHC.Types.Var.Env -import GHC.Types.Unique.Set -import GHC.Types.Basic ( TypeOrKind(..) - , NonStandardDefaultingStrategy(..) - , DefaultingStrategy(..), defaultNonStandardTyVars ) - -import GHC.Data.FastString -import GHC.Data.Bag -import GHC.Data.Pair - -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) - -import Control.Monad -import GHC.Data.Maybe -import qualified Data.Semigroup as Semi -import GHC.Types.Name.Reader - -{- -************************************************************************ -* * - Kind variables -* * -************************************************************************ --} - -newMetaKindVar :: TcM TcKind -newMetaKindVar - = do { details <- newMetaDetails TauTv - ; name <- newMetaTyVarName (fsLit "k") - -- All MetaKindVars are called "k" - -- They may be jiggled by tidying - ; let kv = mkTcTyVar name liftedTypeKind details - ; traceTc "newMetaKindVar" (ppr kv) - ; return (mkTyVarTy kv) } - -newMetaKindVars :: Int -> TcM [TcKind] -newMetaKindVars n = replicateM n newMetaKindVar - -{- -************************************************************************ -* * - Evidence variables; range over constraints we can abstract over -* * -************************************************************************ --} - -newEvVars :: TcThetaType -> TcM [EvVar] -newEvVars theta = mapM newEvVar theta - --------------- - -newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar --- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name ManyTy ty) } - --- | Create a new Wanted constraint with the given 'CtLoc'. -newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence -newWantedWithLoc loc pty - = do dst <- case classifyPredType pty of - EqPred {} -> HoleDest <$> newCoercionHole pty - _ -> EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = dst - , ctev_pred = pty - , ctev_loc = loc - , ctev_rewriters = emptyRewriterSet } - --- | Create a new Wanted constraint with the given 'CtOrigin', and --- location information taken from the 'TcM' environment. -newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence --- Deals with both equality and non-equality predicates -newWanted orig t_or_k pty - = do loc <- getCtLocM orig t_or_k - newWantedWithLoc loc pty - --- | Create new Wanted constraints with the given 'CtOrigin', --- and location information taken from the 'TcM' environment. -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig Nothing) - ----------------------------------------------- --- Cloning constraints ----------------------------------------------- - -cloneWantedCtEv :: CtEvidence -> TcM CtEvidence -cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) - | isEqPrimPred pty - = do { co_hole <- newCoercionHole pty - ; return (ctev { ctev_dest = HoleDest co_hole }) } - | otherwise - = pprPanic "cloneWantedCtEv" (ppr pty) -cloneWantedCtEv ctev = return ctev - -cloneWanted :: Ct -> TcM Ct -cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct) - -cloneWC :: WantedConstraints -> TcM WantedConstraints --- Clone all the evidence bindings in --- a) the ic_bind field of any implications --- b) the CoercionHoles of any wanted constraints --- so that solving the WantedConstraints will not have any visible side --- effect, /except/ from causing unifications -cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { simples' <- mapBagM cloneWanted simples - ; implics' <- mapBagM cloneImplication implics - ; return (wc { wc_simple = simples', wc_impl = implics' }) } - -cloneImplication :: Implication -> TcM Implication -cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) - = do { binds' <- cloneEvBindsVar binds - ; inner_wanted' <- cloneWC inner_wanted - ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } - ----------------------------------------------- --- Emitting constraints ----------------------------------------------- - --- | Emits a new Wanted. Deals with both equalities and non-equalities. -emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm -emitWanted origin pty - = do { ev <- newWanted origin Nothing pty - ; emitSimple $ mkNonCanonical ev - ; return $ ctEvTerm ev } - -emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () --- Emit some new wanted nominal equalities -emitWantedEqs origin pairs - | null pairs - = return () - | otherwise - = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs - --- | Emits a new equality constraint -emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion -emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHole pty - ; loc <- getCtLocM origin (Just t_or_k) - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty - , ctev_dest = HoleDest hole - , ctev_loc = loc - , ctev_rewriters = rewriterSetFromTypes [ty1, ty2] } - ; return (HoleCo hole) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Creates a new EvVar and immediately emits it as a Wanted. --- No equality predicates here. -emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar -emitWantedEvVar origin ty - = do { new_cv <- newEvVar ty - ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv - , ctev_pred = ty - , ctev_loc = loc - , ctev_rewriters = emptyRewriterSet } - ; emitSimple $ mkNonCanonical ctev - ; return new_cv } - -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] -emitWantedEvVars orig = mapM (emitWantedEvVar orig) - --- | Emit a new wanted expression hole -emitNewExprHole :: RdrName -- of the hole - -> Type -> TcM HoleExprRef -emitNewExprHole occ ty - = do { u <- newUnique - ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) - ; let her = HER ref ty u - - ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) - - ; let hole = Hole { hole_sort = ExprHole her - , hole_occ = occ - , hole_ty = ty - , hole_loc = loc } - ; emitHole hole - ; return her } - -newDict :: Class -> [TcType] -> TcM DictId -newDict cls tys - = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } - -predTypeOccName :: PredType -> OccName -predTypeOccName ty = case classifyPredType ty of - ClassPred cls _ -> mkDictOcc (getOccName cls) - EqPred {} -> mkVarOccFS (fsLit "co") - IrredPred {} -> mkVarOccFS (fsLit "irred") - ForAllPred {} -> mkVarOccFS (fsLit "df") - --- | Create a new 'Implication' with as many sensible defaults for its fields --- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do --- /not/ have sensible defaults, so they are initialized with lazy thunks that --- will 'panic' if forced, so one should take care to initialize these fields --- after creation. --- --- This is monadic to look up the 'TcLclEnv', which is used to initialize --- 'ic_env', and to set the -Winaccessible-code flag. See --- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". -newImplication :: TcM Implication -newImplication - = do env <- getLclEnv - warn_inaccessible <- woptM Opt_WarnInaccessibleCode - return (implicationPrototype { ic_env = env - , ic_warn_inaccessible = warn_inaccessible }) - -{- -************************************************************************ -* * - Coercion holes -* * -************************************************************************ --} - -newCoercionHole :: TcPredType -> TcM CoercionHole -newCoercionHole pred_ty - = do { co_var <- newEvVar pred_ty - ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) - ; ref <- newMutVar Nothing - ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } - --- | Put a value in a coercion hole -fillCoercionHole :: CoercionHole -> Coercion -> TcM () -fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do - when debugIsOn $ do - cts <- readTcRef ref - whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) - traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) - writeTcRef ref (Just co) - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref - --- | Check that a coercion is appropriate for filling a hole. (The hole --- itself is needed only for printing.) --- Always returns the checked coercion, but this return value is necessary --- so that the input coercion is forced only when the output is forced. -checkCoercionHole :: CoVar -> Coercion -> TcM Coercion -checkCoercionHole cv co - | debugIsOn - = do { cv_ty <- zonkTcType (varType cv) - -- co is already zonked, but cv might not be - ; return $ - assertPpr (ok cv_ty) - (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) - co } - | otherwise - = return co - - where - (Pair t1 t2, role) = coercionKindRole co - ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty - = t1 `eqType` cv_t1 - && t2 `eqType` cv_t2 - && role == eqRelRole cv_rel - | otherwise - = False - --- | A coercion hole used to store evidence for `Concrete#` constraints. --- --- See Note [The Concrete mechanism]. -type ConcreteHole = CoercionHole - --- | Create a new (initially unfilled) coercion hole, --- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint. -newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy') - -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep') - -> TcM (ConcreteHole, TcType) - -- ^ where to put the evidence, and a metavariable to store - -- the concrete type -newConcreteHole ki ty - = do { concrete_ty <- newFlexiTyVarTy ki - ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty - ; hole <- newCoercionHole co_ty - ; return (hole, concrete_ty) } - -{- ********************************************************************** -* - ExpType functions -* -********************************************************************** -} - -{- Note [ExpType] -~~~~~~~~~~~~~~~~~ -An ExpType is used as the "expected type" when type-checking an expression. -An ExpType can hold a "hole" that can be filled in by the type-checker. -This allows us to have one tcExpr that works in both checking mode and -synthesis mode (that is, bidirectional type-checking). Previously, this -was achieved by using ordinary unification variables, but we don't need -or want that generality. (For example, #11397 was caused by doing the -wrong thing with unification variables.) Instead, we observe that these -holes should - -1. never be nested -2. never appear as the type of a variable -3. be used linearly (never be duplicated) - -By defining ExpType, separately from Type, we can achieve goals 1 and 2 -statically. - -See also [wiki:typechecking] - -Note [TcLevel of ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data G a where - MkG :: G Bool - - foo MkG = True - -This is a classic untouchable-variable / ambiguous GADT return type -scenario. But, with ExpTypes, we'll be inferring the type of the RHS. -We thus must track a TcLevel in an Inferring ExpType. If we try to -fill the ExpType and find that the TcLevels don't work out, we fill -the ExpType with a tau-tv at the low TcLevel, hopefully to be worked -out later by some means -- see fillInferResult, and Note [fillInferResult] - -This behaviour triggered in test gadt/gadt-escape1. - -Note [FixedRuntimeRep context in ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes, we want to be sure that we fill an ExpType with a type -that has a syntactically fixed RuntimeRep (in the sense of -Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). - -Example: - - pattern S a = (a :: (T :: TYPE R)) - -We have to infer a type for `a` which has a syntactically fixed RuntimeRep. -When it comes time to filling in the inferred type, we do the appropriate -representation-polymorphism check, much like we do a level check -as explained in Note [TcLevel of ExpType]. - -See test case T21325. --} - --- actual data definition is in GHC.Tc.Utils.TcType - -newInferExpType :: TcM ExpType -newInferExpType = new_inferExpType Nothing - -newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR -newInferExpTypeFRR frr_orig - = do { th_stage <- getStage - ; if - -- See [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | Brack _ (TcPending {}) <- th_stage - -> new_inferExpType Nothing - - | otherwise - -> new_inferExpType (Just frr_orig) } - -new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType -new_inferExpType mb_frr_orig - = do { u <- newUnique - ; tclvl <- getTcLevel - ; traceTc "newInferExpType" (ppr u <+> ppr tclvl) - ; ref <- newMutVar Nothing - ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref - , ir_frr = mb_frr_orig })) } - --- | Extract a type out of an ExpType, if one exists. But one should always --- exist. Unless you're quite sure you know what you're doing. -readExpType_maybe :: ExpType -> TcM (Maybe TcType) -readExpType_maybe (Check ty) = return (Just ty) -readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref - --- | Same as readExpType, but for Scaled ExpTypes -readScaledExpType :: Scaled ExpType -> TcM (Scaled Type) -readScaledExpType (Scaled m exp_ty) - = do { ty <- readExpType exp_ty - ; return (Scaled m ty) } - --- | Extract a type out of an ExpType. Otherwise, panics. -readExpType :: ExpType -> TcM TcType -readExpType exp_ty - = do { mb_ty <- readExpType_maybe exp_ty - ; case mb_ty of - Just ty -> return ty - Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } - --- | Returns the expected type when in checking mode. -checkingExpType_maybe :: ExpType -> Maybe TcType -checkingExpType_maybe (Check ty) = Just ty -checkingExpType_maybe (Infer {}) = Nothing - --- | Returns the expected type when in checking mode. Panics if in inference --- mode. -checkingExpType :: String -> ExpType -> TcType -checkingExpType _ (Check ty) = ty -checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) - -scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType) -scaledExpTypeToType (Scaled m exp_ty) - = do { ty <- expTypeToType exp_ty - ; return (Scaled m ty) } - --- | Extracts the expected type if there is one, or generates a new --- TauTv if there isn't. -expTypeToType :: ExpType -> TcM TcType -expTypeToType (Check ty) = return ty -expTypeToType (Infer inf_res) = inferResultToType inf_res - -inferResultToType :: InferResult -> TcM Type -inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref - , ir_frr = mb_frr }) - = do { mb_inferred_ty <- readTcRef ref - ; tau <- case mb_inferred_ty of - Just ty -> do { ensureMonoType ty - -- See Note [inferResultToType] - ; return ty } - Nothing -> do { tau <- new_meta - ; writeMutVar ref (Just tau) - ; return tau } - ; traceTc "Forcing ExpType to be monomorphic:" - (ppr u <+> text ":=" <+> ppr tau) - ; return tau } - where - -- See Note [TcLevel of ExpType] - new_meta = case mb_frr of - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } - Just frr -> mdo { rr <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) - ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr - ; return tau } - -{- Note [inferResultToType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -expTypeToType and inferResultType convert an InferResult to a monotype. -It must be a monotype because if the InferResult isn't already filled in, -we fill it in with a unification variable (hence monotype). So to preserve -order-independence we check for mono-type-ness even if it *is* filled in -already. - -See also Note [TcLevel of ExpType] above, and -Note [fillInferResult] in GHC.Tc.Utils.Unify. --} - --- | Infer a type using a fresh ExpType --- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" --- --- Use 'tcInferFRR' if you require the type to have a fixed --- runtime representation. -tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer = tc_infer Nothing - --- | Like 'tcInfer', except it ensures that the resulting type --- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in --- GHC.Tc.Utils.Concrete. -tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) -tcInferFRR frr_orig = tc_infer (Just frr_orig) - -tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tc_infer mb_frr tc_check - = do { res_ty <- new_inferExpType mb_frr - ; result <- tc_check res_ty - ; res_ty <- readExpType res_ty - ; return (result, res_ty) } - -{- ********************************************************************* -* * - Promoting types -* * -********************************************************************* -} - -ensureMonoType :: TcType -> TcM () --- Assuming that the argument type is of kind (TYPE r), --- ensure that it is a /monotype/ --- If it is not a monotype we can see right away (since unification --- variables and type-function applications stand for monotypes), but --- we emit a Wanted equality just to delay the error message until later -ensureMonoType res_ty - | isTauTy res_ty -- isTauTy doesn't need zonking or anything - = return () - | otherwise - = do { mono_ty <- newOpenFlexiTyVarTy - ; let eq_orig = TypeEqOrigin { uo_actual = res_ty - , uo_expected = mono_ty - , uo_thing = Nothing - , uo_visible = False } - - ; _co <- emitWantedEq eq_orig TypeLevel Nominal res_ty mono_ty - ; return () } - -promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) --- See Note [Promoting a type] --- See also Note [fillInferResult] --- promoteTcType level ty = (co, ty') --- * Returns ty' whose max level is just 'level' --- and whose kind is ~# to the kind of 'ty' --- and whose kind has form TYPE rr --- * and co :: ty ~ ty' --- * and emits constraints to justify the coercion --- --- NB: we expect that 'ty' has already kind (TYPE rr) for --- some rr::RuntimeRep. It is, after all, the type of a term. -promoteTcType dest_lvl ty - = do { cur_lvl <- getTcLevel - ; if (cur_lvl `sameDepthAs` dest_lvl) - then return (mkNomReflCo ty, ty) - else promote_it } - where - promote_it :: TcM (TcCoercion, TcType) - promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty - -- where alpha and rr are fresh and from level dest_lvl - = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) - ; let eq_orig = TypeEqOrigin { uo_actual = ty - , uo_expected = prom_ty - , uo_thing = Nothing - , uo_visible = False } - - ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty - ; return (co, prom_ty) } - -{- Note [Promoting a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12427) - - data T where - MkT :: (Int -> Int) -> a -> T - - h y = case y of MkT v w -> v - -We'll infer the RHS type with an expected type ExpType of - (IR { ir_lvl = l, ir_ref = ref, ... ) -where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern -match will increase the level, so we'll end up in tcSubType, trying to -unify the type of v, - v :: Int -> Int -with the expected type. But this attempt takes place at level (l+1), -rightly so, since v's type could have mentioned existential variables, -(like w's does) and we want to catch that. - -So we - - create a new meta-var alpha[l+1] - - fill in the InferRes ref cell 'ref' with alpha - - emit an equality constraint, thus - [W] alpha[l+1] ~ (Int -> Int) - -That constraint will float outwards, as it should, unless v's -type mentions a skolem-captured variable. - -This approach fails if v has a higher rank type; see -Note [Promotion and higher rank types] - - -Note [Promotion and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If v had a higher-rank type, say v :: (forall a. a->a) -> Int, -then we'd emit an equality - [W] alpha[l+1] ~ ((forall a. a->a) -> Int) -which will sadly fail because we can't unify a unification variable -with a polytype. But there is nothing really wrong with the program -here. - -We could just about solve this by "promote the type" of v, to expose -its polymorphic "shape" while still leaving constraints that will -prevent existential escape. But we must be careful! Exposing -the "shape" of the type is precisely what we must NOT do under -a GADT pattern match! So in this case we might promote the type -to - (forall a. a->a) -> alpha[l+1] -and emit the constraint - [W] alpha[l+1] ~ Int -Now the promoted type can fill the ref cell, while the emitted -equality can float or not, according to the usual rules. - -But that's not quite right! We are exposing the arrow! We could -deal with that too: - (forall a. mu[l+1] a a) -> alpha[l+1] -with constraints - [W] alpha[l+1] ~ Int - [W] mu[l+1] ~ (->) -Here we abstract over the '->' inside the forall, in case that -is subject to an equality constraint from a GADT match. - -Note that we kept the outer (->) because that's part of -the polymorphic "shape". And because of impredicativity, -GADT matches can't give equalities that affect polymorphic -shape. - -This reasoning just seems too complicated, so I decided not -to do it. These higher-rank notes are just here to record -the thinking. --} - - -{- ********************************************************************* -* * - MetaTvs (meta type variables; mutable) -* * -********************************************************************* -} - -{- Note [TyVarTv] -~~~~~~~~~~~~~~~~~ -A TyVarTv can unify with type *variables* only, including other TyVarTvs and -skolems. They are used in two places: - -1. In kind signatures, see GHC.Tc.TyCl - Note [Inferring kinds for type declarations] - and Note [Using TyVarTvs for kind-checking GADTs] - -2. In partial type signatures. See GHC.Tc.Types - Note [Quantified variables in partial type signatures] - -Sometimes, they can unify with type variables that the user would -rather keep distinct; see #11203 for an example. So, any client of -this function needs to either allow the TyVarTvs to unify with each -other or check that they don't. In the case of (1) the check is done -in GHC.Tc.TyCl.swizzleTcTyConBndrs. In case of (2) it's done by -findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. - -Historical note: Before #15050 this (under the name SigTv) was also -used for ScopedTypeVariables in patterns, to make sure these type -variables only refer to other type variables, but this restriction was -dropped, and ScopedTypeVariables can now refer to full types (GHC -Proposal 29). --} - -newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and --- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2) -newMetaTyVarName str - = do { uniq <- newUnique - ; return (mkSystemName uniq (mkTyVarOccFS str)) } - -cloneMetaTyVarName :: Name -> TcM Name -cloneMetaTyVarName name - = do { uniq <- newUnique - ; return (mkSystemName uniq (nameOccName name)) } - -- See Note [Name of an instantiated type variable] - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. --} - -metaInfoToTyVarName :: MetaInfo -> FastString -metaInfoToTyVarName meta_info = - case meta_info of - TauTv -> fsLit "t" - TyVarTv -> fsLit "a" - RuntimeUnkTv -> fsLit "r" - CycleBreakerTv -> fsLit "b" - ConcreteTv {} -> fsLit "c" - -newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi - -newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar --- Make a new meta tyvar out of thin air -newNamedAnonMetaTyVar tyvar_name meta_info kind - - = do { name <- newMetaTyVarName tyvar_name - ; details <- newMetaDetails meta_info - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newAnonMetaTyVar" (ppr tyvar) - ; return tyvar } - --- makes a new skolem tv -newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar -newSkolemTyVar skol_info name kind - = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } - -newTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Does not clone a fresh unique -newTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newTyVarTyVar" (ppr tyvar) - ; return tyvar } - -cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Clones a fresh unique -cloneTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar, which makes a SystemName - -- We want to keep the original more user-friendly Name - -- In practical terms that means that in error messages, - -- when the Name is tidied we get 'a' rather than 'a0' - ; traceTc "cloneTyVarTyVar" (ppr tyvar) - ; return tyvar } - --- | Create a new metavariable, of the given kind, which can only be unified --- with a concrete type. --- --- Invariant: the kind must be concrete, as per Note [ConcreteTv]. --- This is checked with an assertion. -newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> TcKind -> TcM TcTyVar -newConcreteTyVar reason kind = - assertPpr (isConcrete kind) - (text "newConcreteTyVar: non-concrete kind" <+> ppr kind) - $ newAnonMetaTyVar (ConcreteTv reason) kind - -newPatSigTyVar :: Name -> Kind -> TcM TcTyVar -newPatSigTyVar name kind - = do { details <- newMetaDetails TauTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar; - -- same reasoning as in newTyVarTyVar - ; traceTc "newPatSigTyVar" (ppr tyvar) - ; return tyvar } - -cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar --- Make a fresh MetaTyVar, basing the name --- on that of the supplied TyVar -cloneAnonMetaTyVar info tv kind - = do { details <- newMetaDetails info - ; name <- cloneMetaTyVarName (tyVarName tv) - ; let tyvar = mkTcTyVar name kind details - ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) - ; return tyvar } - --- Make a new CycleBreakerTv. See Note [Type equality cycles] --- in GHC.Tc.Solver.Canonical. -newCycleBreakerTyVar :: TcKind -> TcM TcTyVar -newCycleBreakerTyVar kind - = do { details <- newMetaDetails CycleBreakerTv - ; name <- newMetaTyVarName (fsLit "cbv") - ; return (mkTcTyVar name kind details) } - -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails -newTauTvDetailsAtLevel tclvl - = do { ref <- newMutVar Flexi - ; return (MetaTv { mtv_info = TauTv - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails -newConcreteTvDetailsAtLevel conc_orig tclvl - = do { ref <- newMutVar Flexi - ; return (MetaTv { mtv_info = ConcreteTv conc_orig - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -cloneMetaTyVar :: TcTyVar -> TcM TcTyVar -cloneMetaTyVar tv - = assert (isTcTyVar tv) $ - do { ref <- newMutVar Flexi - ; name' <- cloneMetaTyVarName (tyVarName tv) - ; let details' = case tcTyVarDetails tv of - details@(MetaTv {}) -> details { mtv_ref = ref } - _ -> pprPanic "cloneMetaTyVar" (ppr tv) - tyvar = mkTcTyVar name' (tyVarKind tv) details' - ; traceTc "cloneMetaTyVar" (ppr tyvar) - ; return tyvar } - --- Works for both type and kind variables -readMetaTyVar :: TyVar -> TcM MetaDetails -readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $ - readMutVar (metaTyVarRef tyvar) - -isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) -isFilledMetaTyVar_maybe tv --- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails --- at the moment (Jan 22) - | isTcTyVar tv - , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { cts <- readTcRef ref - ; case cts of - Indirect ty -> return (Just ty) - Flexi -> return Nothing } - | otherwise - = return Nothing - -isFilledMetaTyVar :: TyVar -> TcM Bool --- True of a filled-in (Indirect) meta type variable -isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv - -isUnfilledMetaTyVar :: TyVar -> TcM Bool --- True of a un-filled-in (Flexi) meta type variable --- NB: Not the opposite of isFilledMetaTyVar -isUnfilledMetaTyVar tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { details <- readMutVar ref - ; return (isFlexi details) } - | otherwise = return False - --------------------- --- Works with both type and kind variables -writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () --- Write into a currently-empty MetaTyVar - -writeMetaTyVar tyvar ty - | not debugIsOn - = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty - --- Everything from here on only happens if DEBUG is on - | not (isTcTyVar tyvar) - = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar) - - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar - = writeMetaTyVarRef tyvar ref ty - - | otherwise - = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) - --------------------- -writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM () --- Here the tyvar is for error checking only; --- the ref cell must be for the same tyvar -writeMetaTyVarRef tyvar ref ty - | not debugIsOn - = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - <+> text ":=" <+> ppr ty) - ; writeTcRef ref (Indirect ty) } - - -- Everything from here on only happens if DEBUG is on - -- Need to zonk 'ty' because we may only recently have promoted - -- its free meta-tyvars (see Solver.Interact.tryToSolveByUnification) - | otherwise - = do { meta_details <- readMutVar ref; - -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcType tv_kind - ; zonked_ty <- zonkTcType ty - ; let zonked_ty_kind = typeKind zonked_ty - zonked_ty_lvl = tcTypeLevel zonked_ty - level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) - level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind - -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType - - kind_msg = hang (text "Ill-kinded update to meta tyvar") - 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) - <+> text ":=" - <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) - - ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - - -- Check for double updates - ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details) - - -- Check for level OK - ; massertPpr level_check_ok level_check_msg - - -- Check Kinds ok - ; massertPpr kind_check_ok kind_msg - - -- Do the write - ; writeMutVar ref (Indirect ty) } - where - tv_kind = tyVarKind tyvar - - tv_lvl = tcTyVarLevel tyvar - - - double_upd_msg details = hang (text "Double update of meta tyvar") - 2 (ppr tyvar $$ ppr details) - -{- -************************************************************************ -* * - MetaTvs: TauTvs -* * -************************************************************************ - -Note [Never need to instantiate coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With coercion variables sloshing around in types, it might seem that we -sometimes need to instantiate coercion variables. This would be problematic, -because coercion variables inhabit unboxed equality (~#), and the constraint -solver thinks in terms only of boxed equality (~). The solution is that -we never need to instantiate coercion variables in the first place. - -The tyvars that we need to instantiate come from the types of functions, -data constructors, and patterns. These will never be quantified over -coercion variables, except for the special case of the promoted Eq#. But, -that can't ever appear in user code, so we're safe! --} - - -newMultiplicityVar :: TcM TcType -newMultiplicityVar = newFlexiTyVarTy multiplicityTy - -newFlexiTyVar :: Kind -> TcM TcTyVar -newFlexiTyVar kind = newAnonMetaTyVar TauTv kind - --- | Create a new flexi ty var with a specific name -newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar -newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind - -newFlexiTyVarTy :: Kind -> TcM TcType -newFlexiTyVarTy kind = do - tc_tyvar <- newFlexiTyVar kind - return (mkTyVarTy tc_tyvar) - -newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] -newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) - -newOpenTypeKind :: TcM TcKind -newOpenTypeKind - = do { rr <- newFlexiTyVarTy runtimeRepTy - ; return (mkTYPEapp rr) } - --- | Create a tyvar that can be a lifted or unlifted type. --- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh -newOpenFlexiTyVarTy :: TcM TcType -newOpenFlexiTyVarTy - = do { tv <- newOpenFlexiTyVar - ; return (mkTyVarTy tv) } - -newOpenFlexiTyVar :: TcM TcTyVar -newOpenFlexiTyVar - = do { kind <- newOpenTypeKind - ; newFlexiTyVar kind } - -newOpenBoxedTypeKind :: TcM TcKind -newOpenBoxedTypeKind - = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) - ; let rr = mkTyConApp boxedRepDataConTyCon [lev] - ; return (mkTYPEapp rr) } - -newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar]) --- Instantiate with META type variables --- Note that this works for a sequence of kind, type, and coercion variables --- variables. Eg [ (k:*), (a:k->k) ] --- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = newMetaTyVarsX emptySubst - -- emptySubst has an empty in-scope set, but that's fine here - -- Since the tyvars are freshly made, they cannot possibly be - -- captured by any existing for-alls. - -newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst - -newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) --- Make a new unification variable tyvar whose Name and Kind come from --- an existing TyVar. We substitute kind variables in the kind. -newMetaTyVarX = new_meta_tv_x TauTv - -newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) --- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX = new_meta_tv_x TyVarTv - -newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -newWildCardX subst tv - = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) - ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } - -new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar) -new_meta_tv_x info subst tv - = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind - ; let subst1 = extendTvSubstWithClone subst tv new_tv - ; return (subst1, new_tv) } - where - substd_kind = substTyUnchecked subst (tyVarKind tv) - -- NOTE: #12549 is fixed so we could use - -- substTy here, but the tc_infer_args problem - -- is not yet fixed so leaving as unchecked for now. - -- OLD NOTE: - -- Unchecked because we call newMetaTyVarX from - -- tcInstTyBinder, which is called from tcInferTyApps - -- which does not yet take enough trouble to ensure - -- the in-scope set is right; e.g. #12785 trips - -- if we use substTy here - -newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType -newMetaTyVarTyAtLevel tc_lvl kind - = do { details <- newTauTvDetailsAtLevel tc_lvl - ; name <- newMetaTyVarName (fsLit "p") - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - -newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType -newConcreteTyVarAtLevel conc_orig tc_lvl kind - = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl - ; name <- newMetaTyVarName (fsLit "c") - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - - -{- ********************************************************************* -* * - Finding variables to quantify over -* * -********************************************************************* -} - -{- Note [Dependent type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell type inference we quantify over type variables; but we only -quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds -we default the kind variables to *. - -So, to support this defaulting, and only for that reason, when -collecting the free vars of a type (in candidateQTyVarsOfType and friends), -prior to quantifying, we must keep the type and kind variables separate. - -But what does that mean in a system where kind variables /are/ type -variables? It's a fairly arbitrary distinction based on how the -variables appear: - - - "Kind variables" appear in the kind of some other free variable - or in the kind of a locally quantified type variable - (forall (a :: kappa). ...) or in the kind of a coercion - (a |> (co :: kappa1 ~ kappa2)). - - These are the ones we default to * if -XPolyKinds is off - - - "Type variables" are all free vars that are not kind variables - -E.g. In the type T k (a::k) - 'k' is a kind variable, because it occurs in the kind of 'a', - even though it also appears at "top level" of the type - 'a' is a type variable, because it doesn't - -We gather these variables using a CandidatesQTvs record: - DV { dv_kvs: Variables free in the kind of a free type variable - or of a forall-bound type variable - , dv_tvs: Variables syntactically free in the type } - -So: dv_kvs are the kind variables of the type - (dv_tvs - dv_kvs) are the type variable of the type - -Note that - -* A variable can occur in both. - T k (x::k) The first occurrence of k makes it - show up in dv_tvs, the second in dv_kvs - -* We include any coercion variables in the "dependent", - "kind-variable" set because we never quantify over them. - -* The "kind variables" might depend on each other; e.g - (k1 :: k2), (k2 :: *) - The "type variables" do not depend on each other; if - one did, it'd be classified as a kind variable! - -Note [CandidatesQTvs determinism and order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Determinism: when we quantify over type variables we decide the - order in which they appear in the final type. Because the order of - type variables in the type can end up in the interface file and - affects some optimizations like worker-wrapper, we want this order to - be deterministic. - - To achieve that we use deterministic sets of variables that can be - converted to lists in a deterministic order. For more information - about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - -* Order: as well as being deterministic, we use an - accumulating-parameter style for candidateQTyVarsOfType so that we - add variables one at a time, left to right. That means we tend to - produce the variables in left-to-right order. This is just to make - it bit more predictable for the programmer. - -Note [Naughty quantification candidates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14880, dependent/should_compile/T14880-2), suppose -we are trying to generalise this type: - - forall arg. ... (alpha[tau]:arg) ... - -We have a metavariable alpha whose kind mentions a skolem variable -bound inside the very type we are generalising. -This can arise while type-checking a user-written type signature -(see the test case for the full code). - -We cannot generalise over alpha! That would produce a type like - forall {a :: arg}. forall arg. ...blah... -The fact that alpha's kind mentions arg renders it completely -ineligible for generalisation. - -However, we are not going to learn any new constraints on alpha, -because its kind isn't even in scope in the outer context (but see Wrinkle). -So alpha is entirely unconstrained. - -What then should we do with alpha? During generalization, every -metavariable is either (A) promoted, (B) generalized, or (C) zapped -(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType). - - * We can't generalise it. - * We can't promote it, because its kind prevents that - * We can't simply leave it be, because this type is about to - go into the typing environment (as the type of some let-bound - variable, say), and then chaos erupts when we try to instantiate. - -Previously, we zapped it to Any. This worked, but it had the unfortunate -effect of causing Any sometimes to appear in error messages. If this -kind of signature happens, the user probably has made a mistake -- no -one really wants Any in their types. So we now error. This must be -a hard error (failure in the monad) to avoid other messages from mentioning -Any. - -We do this eager erroring in candidateQTyVars, which always precedes -generalisation, because at that moment we have a clear picture of what -skolems are in scope within the type itself (e.g. that 'forall arg'). - -This change is inspired by and described in Section 7.2 of "Kind Inference -for Datatypes", POPL'20. - -NB: this is all rather similar to, but sadly not the same as - Note [Error on unconstrained meta-variables] - -Wrinkle: - -We must make absolutely sure that alpha indeed is not -from an outer context. (Otherwise, we might indeed learn more information -about it.) This can be done easily: we just check alpha's TcLevel. -That level must be strictly greater than the ambient TcLevel in order -to treat it as naughty. We say "strictly greater than" because the call to -candidateQTyVars is made outside the bumped TcLevel, as stated in the -comment to candidateQTyVarsOfType. The level check is done in go_tv -in collect_cand_qtvs. Skipping this check caused #16517. - --} - -data CandidatesQTvs - -- See Note [Dependent type variables] - -- See Note [CandidatesQTvs determinism and order] - -- - -- Invariants: - -- * All variables are fully zonked, including their kinds - -- * All variables are at a level greater than the ambient level - -- See Note [Use level numbers for quantification] - -- - -- This *can* contain skolems. For example, in `data X k :: k -> Type` - -- we need to know that the k is a dependent variable. This is done - -- by collecting the candidates in the kind after skolemising. It also - -- comes up when generalizing a associated type instance, where instance - -- variables are skolems. (Recall that associated type instances are generalized - -- independently from their enclosing class instance, and the associated - -- type instance may be generalized by more, fewer, or different variables - -- than the class instance.) - -- - = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) - , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) - -- A variable may appear in both sets - -- E.g. T k (x::k) The first occurrence of k makes it - -- show up in dv_tvs, the second in dv_kvs - -- See Note [Dependent type variables] - - , dv_cvs :: CoVarSet - -- These are covars. Included only so that we don't repeatedly - -- look at covars' kinds in accumulator. Not used by quantifyTyVars. - } - -instance Semi.Semigroup CandidatesQTvs where - (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) - <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) - = DV { dv_kvs = kv1 `unionDVarSet` kv2 - , dv_tvs = tv1 `unionDVarSet` tv2 - , dv_cvs = cv1 `unionVarSet` cv2 } - -instance Monoid CandidatesQTvs where - mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } - mappend = (Semi.<>) - -instance Outputable CandidatesQTvs where - ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) - = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs - , text "dv_tvs =" <+> ppr tvs - , text "dv_cvs =" <+> ppr cvs ]) - -isEmptyCandidates :: CandidatesQTvs -> Bool -isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) - = isEmptyDVarSet kvs && isEmptyDVarSet tvs - --- | Extract out the kind vars (in order) and type vars (in order) from --- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping --- the lists separate is important only in the -XNoPolyKinds case. -candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar]) -candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) - = (dep_kvs, nondep_tvs) - where - dep_kvs = scopedSort $ dVarSetElems dep_kv_set - -- scopedSort: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way round - - nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) - -- See Note [Dependent type variables] - -- The `minus` dep_tkvs removes any kind-level vars - -- e.g. T k (a::k) Since k appear in a kind it'll - -- be in dv_kvs, and is dependent. So remove it from - -- dv_tvs which will also contain k - -- NB kinds of tvs are already zonked - -candidateKindVars :: CandidatesQTvs -> TyVarSet -candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) - -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs -delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars - = DV { dv_kvs = kvs `delDVarSetList` vars - , dv_tvs = tvs `delDVarSetList` vars - , dv_cvs = cvs `delVarSetList` vars } - -partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) --- The selected TyVars are returned as a non-deterministic TyVarSet -partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred - = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) - where - (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs - (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs - extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs - -candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs --- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars --- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose --- of Note [Naughty quantification candidates]. Why? --- Because we are going to scoped-sort the quantified variables --- in among the tvs -candidateQTyVarsWithBinders bound_tvs ty - = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) - ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty - ; return (all_tvs `delCandidates` bound_tvs) } - --- | Gathers free variables to use as quantification candidates (in --- 'quantifyTyVars'). This might output the same var --- in both sets, if it's used in both a type and a kind. --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) --- See Note [CandidatesQTvs determinism and order] --- See Note [Dependent type variables] -candidateQTyVarsOfType :: TcType -- not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty - --- | Like 'candidateQTyVarsOfType', but over a list of types --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs -candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty) - mempty tys - --- | Like 'candidateQTyVarsOfType', but consider every free variable --- to be dependent. This is appropriate when generalizing a *kind*, --- instead of a type. (That way, -XNoPolyKinds will default the variables --- to Type.) -candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty - -candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty) - mempty tys - -collect_cand_qtvs - :: TcType -- original type that we started recurring into; for errors - -> Bool -- True <=> consider every fv in Type to be dependent - -> VarSet -- Bound variables (locals only) - -> CandidatesQTvs -- Accumulating parameter - -> Type -- Not necessarily zonked - -> TcM CandidatesQTvs - --- Key points: --- * Looks through meta-tyvars as it goes; --- no need to zonk in advance --- --- * Needs to be monadic anyway, because it handles naughty --- quantification; see Note [Naughty quantification candidates] --- --- * Returns fully-zonked CandidateQTvs, including their kinds --- so that subsequent dependency analysis (to build a well --- scoped telescope) works correctly - -collect_cand_qtvs orig_ty is_dep bound dvs ty - = go dvs ty - where - is_bound tv = tv `elemVarSet` bound - - ----------------- - go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs - -- Uses accumulating-parameter style - go dv (AppTy t1 t2) = foldlM go dv [t1, t2] - go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys - go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] - go dv (LitTy {}) = return dv - go dv (CastTy ty co) = do dv1 <- go dv ty - collect_cand_qtvs_co orig_ty bound dv1 co - go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty bound dv co - - go dv (TyVarTy tv) - | is_bound tv = return dv - | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv - ; case m_contents of - Just ind_ty -> go dv ind_ty - Nothing -> go_tv dv tv } - - go dv (ForAllTy (Bndr tv _) ty) - = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv) - ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty } - - -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha). - -- Tested in polykinds/NestedProxies. - -- We just might get this wrong in AppTy, but I don't think that's possible - -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need - -- to look at kinds. - go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys) - = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr) - bound dv ty - ; go_tc_args dv1 tc_bndrs tys } - go_tc_args dv _bndrs tys -- _bndrs might be non-empty: undersaturation - -- tys might be non-empty: oversaturation - -- either way, the foldlM is correct - = foldlM go dv tys - - ----------------- - go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | tv `elemDVarSet` kvs - = return dv -- We have met this tyvar already - - | not is_dep - , tv `elemDVarSet` tvs - = return dv -- We have met this tyvar already - - | otherwise - = do { tv_kind <- zonkTcType (tyVarKind tv) - -- This zonk is annoying, but it is necessary, both to - -- ensure that the collected candidates have zonked kinds - -- (#15795) and to make the naughty check - -- (which comes next) works correctly - - ; let tv_kind_vars = tyCoVarsOfType tv_kind - ; cur_lvl <- getTcLevel - ; if | tcTyVarLevel tv <= cur_lvl - -> return dv -- this variable is from an outer context; skip - -- See Note [Use level numbers for quantification] - - | case tcTyVarDetails tv of - SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl - _ -> False - -> return dv -- Skip inner skolems; ToDo: explain - - | intersectsVarSet bound tv_kind_vars - -- the tyvar must not be from an outer context, but we have - -- already checked for this. - -- See Note [Naughty quantification candidates] - -> do { traceTc "Naughty quantifier" $ - vcat [ ppr tv <+> dcolon <+> ppr tv_kind - , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) - , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] - - ; let escapees = intersectVarSet bound tv_kind_vars - ; naughtyQuantification orig_ty tv escapees } - - | otherwise - -> do { let tv' = tv `setTyVarKind` tv_kind - dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } - | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } - -- See Note [Order of accumulation] - - -- See Note [Recurring into kinds for candidateQTyVars] - ; collect_cand_qtvs orig_ty True bound dv' tv_kind } } - -collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors - -> VarSet -- bound variables - -> CandidatesQTvs -> Coercion - -> TcM CandidatesQTvs -collect_cand_qtvs_co orig_ty bound = go_co - where - go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty - go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty - go_mco dv1 mco - go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos - go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2] - go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos - go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos - go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov - dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1 - collect_cand_qtvs orig_ty True bound dv2 t2 - go_co dv (SymCo co) = go_co dv co - go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (SelCo _ co) = go_co dv co - go_co dv (LRCo _ co) = go_co dv co - go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (KindCo co) = go_co dv co - go_co dv (SubCo co) = go_co dv co - - go_co dv (HoleCo hole) - = do m_co <- unpackCoercionHole_maybe hole - case m_co of - Just co -> go_co dv co - Nothing -> go_cv dv (coHoleCoVar hole) - - go_co dv (CoVarCo cv) = go_cv dv cv - - go_co dv (ForAllCo tcv kind_co co) - = do { dv1 <- go_co dv kind_co - ; collect_cand_qtvs_co orig_ty (bound `extendVarSet` tcv) dv1 co } - - go_mco dv MRefl = return dv - go_mco dv (MCo co) = go_co dv co - - go_prov dv (PhantomProv co) = go_co dv co - go_prov dv (ProofIrrelProv co) = go_co dv co - go_prov dv (PluginProv _) = return dv - go_prov dv (CorePrepProv _) = return dv - - go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs - go_cv dv@(DV { dv_cvs = cvs }) cv - | is_bound cv = return dv - | cv `elemVarSet` cvs = return dv - - -- See Note [Recurring into kinds for candidateQTyVars] - | otherwise = collect_cand_qtvs orig_ty True bound - (dv { dv_cvs = cvs `extendVarSet` cv }) - (idType cv) - - is_bound tv = tv `elemVarSet` bound - -{- Note [Order of accumulation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might be tempted (like I was) to use unitDVarSet and mappend -rather than extendDVarSet. However, the union algorithm for -deterministic sets depends on (roughly) the size of the sets. The -elements from the smaller set end up to the right of the elements from -the larger one. When sets are equal, the left-hand argument to -`mappend` goes to the right of the right-hand argument. - -In our case, if we use unitDVarSet and mappend, we learn that the free -variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify -over them in that order. (The a comes after the b because we union the -singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, -the size criterion works to our advantage.) This is just annoying to -users, so I use `extendDVarSet`, which unambiguously puts the new -element to the right. - -Note that the unitDVarSet/mappend implementation would not be wrong -against any specification -- just suboptimal and confounding to users. - -Note [Recurring into kinds for candidateQTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying -attention to the end of the Note about using an empty bound set when -traversing a variable's kind. - -That Note concludes with the recommendation that we empty out the bound -set when recurring into the kind of a type variable. Yet, we do not do -this here. I have two tasks in order to convince you that this code is -right. First, I must show why it is safe to ignore the reasoning in that -Note. Then, I must show why is is necessary to contradict the reasoning in -that Note. - -Why it is safe: There can be no -shadowing in the candidateQ... functions: they work on the output of -type inference, which is seeded by the renamer and its insistence to -use different Uniques for different variables. (In contrast, the Core -functions work on the output of optimizations, which may introduce -shadowing.) Without shadowing, the problem studied by -Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. - -Why it is necessary: -Wiping the bound set would be just plain wrong here. Consider - - forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) - -We really don't want to think k1 and k2 are free here. (It's true that we'll -never be able to fill in `hole`, but we don't want to go off the rails just -because we have an insoluble coercion hole.) So: why is it wrong to wipe -the bound variables here but right in Core? Because the final statement -in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not -every variable is either free or bound. A variable can be a hole, too! -The reasoning in that Note then breaks down. - -And the reasoning applies just as well to free non-hole variables, so we -retain the bound set always. - --} - -{- ********************************************************************* -* * - Quantification -* * -************************************************************************ - -Note [quantifyTyVars] -~~~~~~~~~~~~~~~~~~~~~ -quantifyTyVars is given the free vars of a type that we -are about to wrap in a forall. - -It takes these free type/kind variables (partitioned into dependent and -non-dependent variables) skolemises metavariables with a TcLevel greater -than the ambient level (see Note [Use level numbers for quantification]). - -* This function distinguishes between dependent and non-dependent - variables only to keep correct defaulting behavior with -XNoPolyKinds. - With -XPolyKinds, it treats both classes of variables identically. - -* quantifyTyVars never quantifies over - - a coercion variable (or any tv mentioned in the kind of a covar) - - a runtime-rep variable - -Note [Use level numbers for quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The level numbers assigned to metavariables are very useful. Not only -do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType), -but they also allow us to determine which variables to -generalise. The rule is this: - - When generalising, quantify only metavariables with a TcLevel greater - than the ambient level. - -This works because we bump the level every time we go inside a new -source-level construct. In a traditional generalisation algorithm, we -would gather all free variables that aren't free in an environment. -However, if a variable is in that environment, it will always have a lower -TcLevel: it came from an outer scope. So we can replace the "free in -environment" check with a level-number check. - -Here is an example: - - f x = x + (z True) - where - z y = x * x - -We start by saying (x :: alpha[1]). When inferring the type of z, we'll -quickly discover that z :: alpha[1]. But it would be disastrous to -generalise over alpha in the type of z. So we need to know that alpha -comes from an outer environment. By contrast, the type of y is beta[2], -and we are free to generalise over it. What's the difference between -alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for -generalisation, and so we generalise it. alpha[1] does not, and so -we leave it alone. - -Note that not *every* variable with a higher level will get -generalised, either due to the monomorphism restriction or other -quirks. See, for example, the code in GHC.Tc.Solver.decideMonoTyVars -and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude -certain otherwise-eligible variables from being generalised. - -Using level numbers for quantification is implemented in the candidateQTyVars... -functions, by adding only those variables with a level strictly higher than -the ambient level to the set of candidates. - -Note [quantifyTyVars determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The results of quantifyTyVars are wrapped in a forall and can end up in the -interface file. One such example is inferred type signatures. They also affect -the results of optimizations, for example worker-wrapper. This means that to -get deterministic builds quantifyTyVars needs to be deterministic. - -To achieve this CandidatesQTvs is backed by deterministic sets which allows them -to be later converted to a list in a deterministic order. - -For more information about deterministic sets see -Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. --} - -quantifyTyVars :: SkolemInfo - -> NonStandardDefaultingStrategy - -> CandidatesQTvs -- See Note [Dependent type variables] - -- Already zonked - -> TcM [TcTyVar] --- See Note [quantifyTyVars] --- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations. Also accepts covars, but *never* returns any. --- According to Note [Use level numbers for quantification] and the --- invariants on CandidateQTvs, we do not have to filter out variables --- free in the environment here. Just quantify unconditionally, subject --- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars skol_info ns_strat dvs - -- short-circuit common case - | isEmptyCandidates dvs - = do { traceTc "quantifyTyVars has nothing to quantify" empty - ; return [] } - - | otherwise - = do { traceTc "quantifyTyVars {" - ( vcat [ text "ns_strat =" <+> ppr ns_strat - , text "dvs =" <+> ppr dvs ]) - - ; undefaulted <- defaultTyVars ns_strat dvs - ; final_qtvs <- mapMaybeM zonk_quant undefaulted - - ; traceTc "quantifyTyVars }" - (vcat [ text "undefaulted:" <+> pprTyVars undefaulted - , text "final_qtvs:" <+> pprTyVars final_qtvs ]) - - -- We should never quantify over coercion variables; check this - ; let co_vars = filter isCoVar final_qtvs - ; massertPpr (null co_vars) (ppr co_vars) - - ; return final_qtvs } - where - -- zonk_quant returns a tyvar if it should be quantified over; - -- otherwise, it returns Nothing. The latter case happens for - -- non-meta-tyvars - zonk_quant tkv - | not (isTyVar tkv) - = return Nothing -- this can happen for a covar that's associated with - -- a coercion hole. Test case: typecheck/should_compile/T2494 - - | otherwise - = Just <$> skolemiseQuantifiedTyVar skol_info tkv - -isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification - -> TcTyVar - -> Bool -isQuantifiableTv outer_tclvl tcv - | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately - = tcTyVarLevel tcv > outer_tclvl - | otherwise - = False - -zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> TcM TcTyCoVar --- A tyvar binder is never a unification variable (TauTv), --- rather it is always a skolem. It *might* be a TyVarTv. --- (Because non-CUSK type declarations use TyVarTvs.) --- Regardless, it may have a kind that has not yet been zonked, --- and may include kind unification variables. -zonkAndSkolemise skol_info tyvar - | isTyVarTyVar tyvar - -- We want to preserve the binding location of the original TyVarTv. - -- This is important for error messages. If we don't do this, then - -- we get bad locations in, e.g., typecheck/should_fail/T2688 - = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar - ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } - - | otherwise - = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ - zonkTyCoVarKind tyvar - -skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar --- The quantified type variables often include meta type variables --- we want to freeze them into ordinary type variables --- The meta tyvar is updated to point to the new skolem TyVar. Now any --- bound occurrences of the original type variable will get zonked to --- the immutable version. --- --- We leave skolem TyVars alone; they are immutable. --- --- This function is called on both kind and type variables, --- but kind variables *only* if PolyKinds is on. - -skolemiseQuantifiedTyVar skol_info tv - = case tcTyVarDetails tv of - MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv - - SkolemTv _ lvl _ -- It might be a skolem type variable, - -- for example from a user type signature - -- But it might also be a shared meta-variable across several - -- type declarations, each with its own skol_info. The first - -- will skolemise it, but the other uses must update its - -- skolem info (#22379) - -> do { kind <- zonkTcType (tyVarKind tv) - ; let details = SkolemTv skol_info lvl False - name = tyVarName tv - ; return (mkTcTyVar name kind details) } - - _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk - --- | Default a type variable using the given defaulting strategy. --- --- See Note [Type variable defaulting options] in GHC.Types.Basic. -defaultTyVar :: DefaultingStrategy - -> TcTyVar -- If it's a MetaTyVar then it is unbound - -> TcM Bool -- True <=> defaulted away altogether -defaultTyVar def_strat tv - | not (isMetaTyVar tv) - || isTyVarTyVar tv - -- Do not default TyVarTvs. Doing so would violate the invariants - -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType. - -- #13343 is an example; #14555 is another - -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - = return False - - | isRuntimeRepVar tv - , default_ns_vars - = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy - ; return True } - | isLevityVar tv - , default_ns_vars - = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) - ; writeMetaTyVar tv liftedDataConTy - ; return True } - | isMultiplicityVar tv - , default_ns_vars - = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) - ; writeMetaTyVar tv manyDataConTy - ; return True } - - | isConcreteTyVar tv - -- We don't want to quantify; but neither can we default to - -- anything sensible. (If it has kind RuntimeRep or Levity, as is - -- often the case, it'll have been caught earlier by earlier - -- cases. So in this exotic situation we just promote. Not very - -- satisfing, but it's very much a corner case: #23051) - -- We should really implement the plan in #20686. - = do { lvl <- getTcLevel - ; _ <- promoteMetaTyVarTo lvl tv - ; return True } - - | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it - = default_kind_var tv - - | otherwise - = return False - - where - default_ns_vars :: Bool - default_ns_vars = defaultNonStandardTyVars def_strat - default_kind_var :: TyVar -> TcM Bool - -- defaultKindVar is used exclusively with -XNoPolyKinds - -- See Note [Defaulting with -XNoPolyKinds] - -- It takes an (unconstrained) meta tyvar and defaults it. - -- Works only on vars of type *; for other kinds, it issues an error. - default_kind_var kv - | isLiftedTypeKind (tyVarKind kv) - = do { traceTc "Defaulting a kind var to *" (ppr kv) - ; writeMetaTyVar kv liftedTypeKind - ; return True } - | otherwise - = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) - -- We failed to default it, so return False to say so. - -- Hence, it'll get skolemised. That might seem odd, but we must either - -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType - -- Note [Recipe for checking a signature] - -- Otherwise we get level-number assertion failures. It doesn't matter much - -- because we are in an error situation anyway. - ; return False - } - where - (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv - --- | Default some unconstrained type variables, as specified --- by the defaulting options: --- --- - 'RuntimeRep' tyvars default to 'LiftedRep' --- - 'Levity' tyvars default to 'Lifted' --- - 'Multiplicity' tyvars default to 'Many' --- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds --- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) -defaultTyVars :: NonStandardDefaultingStrategy - -> CandidatesQTvs -- ^ all candidates for quantification - -> TcM [TcTyVar] -- ^ those variables not defaulted -defaultTyVars ns_strat dvs - = do { poly_kinds <- xoptM LangExt.PolyKinds - ; let - def_tvs, def_kvs :: DefaultingStrategy - def_tvs = NonStandardDefaulting ns_strat - def_kvs - | poly_kinds = def_tvs - | otherwise = DefaultKindVars - -- As -XNoPolyKinds precludes polymorphic kind variables, we default them. - -- For example: - -- - -- type F :: Type -> Type - -- type family F a where - -- F (a -> b) = b - -- - -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled - -- we must default the kind variable `r :: RuntimeRep`. - -- Test case: T20584. - ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs - ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs - ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] - undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] - ; return (undefaulted_kvs ++ undefaulted_tvs) } - -- NB: kvs before tvs because tvs may depend on kvs - where - (dep_kvs, nondep_tvs) = candidateVars dvs - -skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar --- We have a Meta tyvar with a ref-cell inside it --- Skolemise it, so that we are totally out of Meta-tyvar-land --- We create a skolem TcTyVar, not a regular TyVar --- See Note [Zonking to Skolem] --- --- Its level should be one greater than the ambient level, which will typically --- be the same as the level on the meta-tyvar. But not invariably; for example --- f :: (forall a b. SameKind a b) -> Int --- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each --- have a level-2 kind unification variable, since it might get unified with another --- of the level-2 skolems e.g. 'k' in this version --- f :: (forall k (a :: k) b. SameKind a b) -> Int --- So when we quantify the kind vars at the top level of the signature, the ambient --- level is 1, but we will quantify over kappa[2]. - -skolemiseUnboundMetaTyVar skol_info tv - = assertPpr (isMetaTyVar tv) (ppr tv) $ - do { check_empty tv - ; tc_lvl <- getTcLevel -- Get the location and level from "here" - ; here <- getSrcSpanM -- i.e. where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let tv_name = tyVarName tv - -- See Note [Skolemising and identity] - final_name | isSystemName tv_name - = mkInternalName (nameUnique tv_name) - (nameOccName tv_name) here - | otherwise - = tv_name - details = SkolemTv skol_info (pushTcLevel tc_lvl) False - final_tv = mkTcTyVar final_name kind details - - ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } - where - check_empty tv -- [Sept 04] Check for non-empty. - = when debugIsOn $ -- See Note [Silly Type Synonyms] - do { cts <- readMetaTyVar tv - ; case cts of - Flexi -> return () - Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $ - return () } - -{- Note [Error on unconstrained meta-variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - -* type C :: Type -> Type -> Constraint - class (forall a. a b ~ a c) => C b c - -* type T = forall a. Proxy a - -* data (forall a. a b ~ a c) => T b c - -* type instance F Int = Proxy Any - where Any :: forall k. k - -In the first three cases we will infer a :: Type -> kappa, but then -we get no further information on kappa. In the last, we will get - Proxy kappa Any -but again will get no further info on kappa. - -What do do? - A. We could choose kappa := Type. But this only works when the kind of kappa - is Type (true in this example, but not always). - B. We could default to Any. - C. We could quantify. - D. We could error. - -We choose (D), as described in #17567, and implement this choice in -doNotQuantifyTyVars. Discussion of alternativs A-C is below. - -NB: this is all rather similar to, but sadly not the same as - Note [Naughty quantification candidates] - -To do this, we must take an extra step before doing the final zonk to create -e.g. a TyCon. (There is no problem in the final term-level zonk. See the -section on alternative (B) below.) This extra step is needed only for -constructs that do not quantify their free meta-variables, such as a class -constraint or right-hand side of a type synonym. - -Specifically: before the final zonk, every construct must either call -quantifyTyVars or doNotQuantifyTyVars. The latter issues an error -if it is passed any free variables. (Exception: we still default -RuntimeRep and Multiplicity variables.) - -Because no meta-variables remain after quantifying or erroring, we perform -the zonk with NoFlexi, which panics upon seeing a meta-variable. - -Alternatives A-C, not implemented: - -A. As stated above, this works only sometimes. We might have a free - meta-variable of kind Nat, for example. - -B. This is what we used to do, but it caused Any to appear in error - messages sometimes. See #17567 for several examples. Defaulting to - Any during the final, whole-program zonk is OK, though, because - we are completely done type-checking at that point. No chance to - leak into an error message. - -C. Examine the class declaration at the top of this Note again. - Where should we quantify? We might imagine quantifying and - putting the kind variable in the forall of the quantified constraint. - But what if there are nested foralls? Which one should get the - variable? Other constructs have other problems. (For example, - the right-hand side of a type family instance equation may not - be a poly-type.) - - More broadly, the GHC AST defines a set of places where it performs - implicit lexical generalization. For example, in a type - signature - - f :: Proxy a -> Bool - - the otherwise-unbound a is lexically quantified, giving us - - f :: forall a. Proxy a -> Bool - - The places that allow lexical quantification are marked in the AST with - HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound - variables. - - Later, during type-checking, we discover that a's kind is unconstrained. - We thus quantify *again*, to - - f :: forall {k} (a :: k). Proxy @k a -> Bool - - It is this second quantification that this Note is really about -- - let's call it *inferred quantification*. - So there are two sorts of implicit quantification in types: - 1. Lexical quantification: signalled by HsImplicitBndrs, occurs over - variables mentioned by the user but with no explicit binding site, - suppressed by a user-written forall (by the forall-or-nothing rule, - in Note [forall-or-nothing rule] in GHC.Hs.Type). - 2. Inferred quantification: no signal in HsSyn, occurs over unconstrained - variables invented by the type-checker, possible only with -XPolyKinds, - unaffected by forall-or-nothing rule - These two quantifications are performed in different compiler phases, and are - essentially unrelated. However, it is convenient - for programmers to remember only one set of implicit quantification - sites. So, we choose to use the same places (those with HsImplicitBndrs) - for lexical quantification as for inferred quantification of unconstrained - meta-variables. Accordingly, there is no quantification in a class - constraint, or the other constructs that call doNotQuantifyTyVars. --} - -doNotQuantifyTyVars :: CandidatesQTvs - -> (TidyEnv -> TcM (TidyEnv, SDoc)) - -- ^ like "the class context (D a b, E foogle)" - -> TcM () --- See Note [Error on unconstrained meta-variables] -doNotQuantifyTyVars dvs where_found - | isEmptyCandidates dvs - = traceTc "doNotQuantifyTyVars has nothing to error on" empty - - | otherwise - = do { traceTc "doNotQuantifyTyVars" (ppr dvs) - ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs - -- could have regular TyVars here, in an associated type RHS, or - -- bound by a type declaration head. So filter looking only for - -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` - -- are OK - ; let leftover_metas = filter isMetaTyVar undefaulted - ; unless (null leftover_metas) $ - do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas - ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let msg = mkTcRnUnknownMessage $ - mkPlainError noHints $ - pprWithExplicitKindsWhen True $ - vcat [ text "Uninferrable type variable" - <> plural tidied_tvs - <+> pprWithCommas pprTyVar tidied_tvs - <+> text "in" - , where_doc ] - ; failWithTcM (tidy_env2, msg) } - ; traceTc "doNotQuantifyTyVars success" empty } - -{- Note [Defaulting with -XNoPolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Compose f g a = Mk (f (g a)) - -We infer - - Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * - Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). - f (g a) -> Compose k1 k2 f g a - -Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. -What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, -we just defaulted all kind variables to *. But that's no good here, -because the kind variables in 'Mk aren't of kind *, so defaulting to * -is ill-kinded. - -After some debate on #11334, we decided to issue an error in this case. -The code is in defaultKindVar. - -Note [What is a meta variable?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "meta type-variable", also know as a "unification variable" is a placeholder -introduced by the typechecker for an as-yet-unknown monotype. - -For example, when we see a call `reverse (f xs)`, we know that we calling - reverse :: forall a. [a] -> [a] -So we know that the argument `f xs` must be a "list of something". But what is -the "something"? We don't know until we explore the `f xs` a bit more. So we set -out what we do know at the call of `reverse` by instantiating its type with a fresh -meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the -result, is `[alpha]`. The unification variable `alpha` stands for the -as-yet-unknown type of the elements of the list. - -As type inference progresses we may learn more about `alpha`. For example, suppose -`f` has the type - f :: forall b. b -> [Maybe b] -Then we instantiate `f`'s type with another fresh unification variable, say -`beta`; and equate `f`'s result type with reverse's argument type, thus -`[alpha] ~ [Maybe beta]`. - -Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've -refined our knowledge about `alpha`. And so on. - -If you found this Note useful, you may also want to have a look at -Section 5 of "Practical type inference for higher rank types" (Peyton Jones, -Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). - -Note [What is zonking?] -~~~~~~~~~~~~~~~~~~~~~~~ -GHC relies heavily on mutability in the typechecker for efficient operation. -For this reason, throughout much of the type checking process meta type -variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable -variables (known as TcRefs). - -Zonking is the process of ripping out these mutable variables and replacing them -with a real Type. This involves traversing the entire type expression, but the -interesting part of replacing the mutable variables occurs in zonkTyVarOcc. - -There are two ways to zonk a Type: - - * zonkTcTypeToType, which is intended to be used at the end of type-checking - for the final zonk. It has to deal with unfilled metavars, either by filling - it with a value like Any or failing (determined by the UnboundTyVarZonker - used). - - * zonkTcType, which will happily ignore unfilled metavars. This is the - appropriate function to use while in the middle of type-checking. - -Note [Zonking to Skolem] -~~~~~~~~~~~~~~~~~~~~~~~~ -We used to zonk quantified type variables to regular TyVars. However, this -leads to problems. Consider this program from the regression test suite: - - eval :: Int -> String -> String -> String - eval 0 root actual = evalRHS 0 root actual - - evalRHS :: Int -> a - evalRHS 0 root actual = eval 0 root actual - -It leads to the deferral of an equality (wrapped in an implication constraint) - - forall a. () => ((String -> String -> String) ~ a) - -which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck). -In the meantime `a' is zonked and quantified to form `evalRHS's signature. -This has the *side effect* of also zonking the `a' in the deferred equality -(which at this point is being handed around wrapped in an implication -constraint). - -Finally, the equality (with the zonked `a') will be handed back to the -simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop. -If we zonk `a' with a regular type variable, we will have this regular type -variable now floating around in the simplifier, which in many places assumes to -only see proper TcTyVars. - -We can avoid this problem by zonking with a skolem TcTyVar. The -skolem is rigid (which we require for a quantified variable), but is -still a TcTyVar that the simplifier knows how to deal with. - -Note [Skolemising and identity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some places, we make a TyVarTv for a binder. E.g. - class C a where ... -As Note [Inferring kinds for type declarations] discusses, -we make a TyVarTv for 'a'. Later we skolemise it, and we'd -like to retain its identity, location info etc. (If we don't -retain its identity we'll have to do some pointless swizzling; -see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity -but not its location we'll lose the detailed binding site info. - -Conclusion: use the Name of the TyVarTv. But we don't want -to do that when skolemising random unification variables; -there the location we want is the skolemisation site. - -Fortunately we can tell the difference: random unification -variables have System Names. That's why final_name is -set based on the isSystemName test. - - -Note [Silly Type Synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - type C u a = u -- Note 'a' unused - - foo :: (forall a. C u a -> C u a) -> u - foo x = ... - - bar :: Num u => u - bar = foo (\t -> t + t) - -* From the (\t -> t+t) we get type {Num d} => d -> d - where d is fresh. - -* Now unify with type of foo's arg, and we get: - {Num (C d a)} => C d a -> C d a - where a is fresh. - -* Now abstract over the 'a', but float out the Num (C d a) constraint - because it does not 'really' mention a. (see exactTyVarsOfType) - The arg to foo becomes - \/\a -> \t -> t+t - -* So we get a dict binding for Num (C d a), which is zonked to give - a = () - Note (Sept 04): now that we are zonking quantified type variables - on construction, the 'a' will be frozen as a regular tyvar on - quantification, so the floated dict will still have type (C d a). - Which renders this whole note moot; happily!] - -* Then the \/\a abstraction has a zonked 'a' in it. - -All very silly. I think its harmless to ignore the problem. We'll end up with -a \/\a in the final result but all the occurrences of a will be zonked to () --} - -{- ********************************************************************* -* * - Promotion -* * -********************************************************************* -} - -promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType --- Return True <=> we did some promotion --- Also returns either the original tyvar (no promotion) or the new one --- See Note [Promoting unification variables] -promoteMetaTyVarTo tclvl tv - | assertPpr (isMetaTyVar tv) (ppr tv) $ - tcTyVarLevel tv `strictlyDeeperThan` tclvl - = do { cloned_tv <- cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; writeMetaTyVar tv (mkTyVarTy rhs_tv) - ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv) - ; return True } - | otherwise - = return False - --- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool -promoteTyVarSet tvs - = do { tclvl <- getTcLevel - ; bools <- mapM (promoteMetaTyVarTo tclvl) $ - filter isPromotableMetaTyVar $ - nonDetEltsUniqSet tvs - -- Non-determinism is OK because order of promotion doesn't matter - ; return (or bools) } - - -{- ********************************************************************* -* * - Zonking types -* * -********************************************************************* -} - -zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet --- Zonk a type and take its free variables --- With kind polymorphism it can be essential to zonk *first* --- so that we find the right set of free variables. Eg --- forall k1. forall (a:k2). a --- where k2:=k1 is in the substitution. We don't want --- k2 to look free in this type! -zonkTcTypeAndFV ty - = tyCoVarsOfTypeDSet <$> zonkTcType ty - -zonkTyCoVar :: TyCoVar -> TcM TcType --- Works on TyVars and TcTyVars -zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv - | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv - | otherwise = assertPpr (isCoVar tv) (ppr tv) $ - mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv - -- Hackily, when typechecking type and class decls - -- we have TyVars in scope added (only) in - -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems - -- painful to make them into TcTyVars there - -zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet -zonkTyCoVarsAndFV tycovars - = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) - -- It's OK to use nonDetEltsUniqSet here because we immediately forget about - -- the ordering by turning it into a nondeterministic set and the order - -- of zonking doesn't matter for determinism. - -zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet -zonkDTyCoVarSetAndFV tycovars - = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) - --- Takes a list of TyCoVars, zonks them and returns a --- deterministically ordered list of their free variables. -zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] -zonkTyCoVarsAndFVList tycovars - = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars - -zonkTcTyVars :: [TcTyVar] -> TcM [TcType] -zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars - ------------------ Types -zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar -zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind') } - -{- -************************************************************************ -* * - Zonking constraints -* * -************************************************************************ --} - -zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given - , ic_wanted = wanted - , ic_info = info }) - = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! - -- as #7230 showed - ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfoAnon info - ; wanted' <- zonkWCRec wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' }) } - -zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = updateIdTypeAndMultM zonkTcType var - - -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC wc = zonkWCRec wc - -zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs }) - = do { simple' <- zonkSimples simple - ; implic' <- mapBagM zonkImplication implic - ; errs' <- mapBagM zonkDelayedError errs - ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) } - -zonkSimples :: Cts -> TcM Cts -zonkSimples cts = do { cts' <- mapBagM zonkCt cts - ; traceTc "zonkSimples done:" (ppr cts') - ; return cts' } - -zonkDelayedError :: DelayedError -> TcM DelayedError -zonkDelayedError (DE_Hole hole) - = DE_Hole <$> zonkHole hole -zonkDelayedError (DE_NotConcrete err) - = DE_NotConcrete <$> zonkNotConcreteError err - -zonkHole :: Hole -> TcM Hole -zonkHole hole@(Hole { hole_ty = ty }) - = do { ty' <- zonkTcType ty - ; return (hole { hole_ty = ty' }) } - -zonkNotConcreteError :: NotConcreteError -> TcM NotConcreteError -zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig }) - = do { frr_orig <- zonkFRROrigin frr_orig - ; return $ err { nce_frr_origin = frr_orig } } - -zonkFRROrigin :: FixedRuntimeRepOrigin -> TcM FixedRuntimeRepOrigin -zonkFRROrigin (FixedRuntimeRepOrigin ty orig) - = do { ty' <- zonkTcType ty - ; return $ FixedRuntimeRepOrigin ty' orig } - -{- Note [zonkCt behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -zonkCt tries to maintain the canonical form of a Ct. For example, - - a CDictCan should stay a CDictCan; - - a CIrredCan should stay a CIrredCan with its cc_reason flag intact - -Why?, for example: -- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the - simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, - constraints are zonked before being passed to the plugin. This means if we - don't preserve a canonical form, @expandSuperClasses@ fails to expand - superclasses. This is what happened in #11525. - -- For CIrredCan we want to see if a constraint is insoluble with insolubleWC - -On the other hand, we change CEqCan to CNonCanonical, because of all of -CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where -we have alpha := N Int, where N is a newtype.) Besides, the constraint -will be canonicalised again, so there is little benefit in keeping the -CEqCan structure. - -NB: Constraints are always rewritten etc by the canonicaliser in -@GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that -are actually in the inert set carry all the guarantees. So it is okay if zonkCt -creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced. --} - -zonkCt :: Ct -> TcM Ct --- See Note [zonkCt behaviour] -zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) - = do { ev' <- zonkCtEvidence ev - ; args' <- mapM zonkTcType args - ; return $ ct { cc_ev = ev', cc_tyargs = args' } } - -zonkCt (CEqCan { cc_ev = ev }) - = mkNonCanonical <$> zonkCtEvidence ev - -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag - = do { ev' <- zonkCtEvidence ev - ; return (ct { cc_ev = ev' }) } - -zonkCt ct - = do { fl' <- zonkCtEvidence (ctEvidence ct) - ; return (mkNonCanonical fl') } - -zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev - = do { pred' <- zonkTcType (ctev_pred ctev) - ; return (setCtEvPredType ctev pred') - } - -zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk - -zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon -zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } - where - do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfoAnon skol_info = return skol_info - -{- -************************************************************************ -* * - Zonking -- the main work-horses: zonkTcType, zonkTcTyVar -* * -************************************************************************ --} - --- For unbound, mutable tyvars, zonkType uses the function given to it --- For tyvars bound at a for-all, zonkType zonks them to an immutable --- type variable and zonks the kind too -zonkTcType :: TcType -> TcM TcType -zonkTcTypes :: [TcType] -> TcM [TcType] -zonkCo :: Coercion -> TcM Coercion - -(zonkTcType, zonkTcTypes, zonkCo, _) - = mapTyCo zonkTcTypeMapper - --- | A suitable TyCoMapper for zonking a type during type-checking, --- before all metavars are filled in. -zonkTcTypeMapper :: TyCoMapper () TcM -zonkTcTypeMapper = TyCoMapper - { tcm_tyvar = const zonkTcTyVar - , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) - , tcm_hole = hole - , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv - , tcm_tycon = zonkTcTyCon } - where - hole :: () -> CoercionHole -> TcM Coercion - hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCo co - ; checkCoercionHole cv co' } - Nothing -> do { cv' <- zonkCoVar cv - ; return $ HoleCo (hole { ch_co_var = cv' }) } } - -zonkTcTyCon :: TcTyCon -> TcM TcTyCon --- Only called on TcTyCons --- A non-poly TcTyCon may have unification --- variables that need zonking, but poly ones cannot -zonkTcTyCon tc - | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc) - ; return (setTcTyConKind tc tck') } - | otherwise = return tc - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - MetaTv { mtv_ref = ref } - -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> do { zty <- zonkTcType ty - ; writeTcRef ref (Indirect zty) - -- See Note [Sharing in zonking] - ; return zty } } - - | otherwise -- coercion variable - = zonk_kind_and_return - where - zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv - ; return (mkTyVarTy z_tv) } - --- Variant that assumes that any result of zonking is still a TyVar. --- Should be used only on skolems and TyVarTvs -zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar] -zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar - -zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTcTyVar tv - = do { ty <- zonkTcTyVar tv - ; let tv' = case getTyVar_maybe ty of - Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTcTyVar" - (ppr tv $$ ppr ty) - ; return tv' } - -zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec) -zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv - ; return (Bndr tv' spec) } - --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id = Id.updateIdTypeAndMultM zonkTcType id - -zonkCoVar :: CoVar -> TcM CoVar -zonkCoVar = zonkId - -{- Note [Sharing in zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - alpha :-> beta :-> gamma :-> ty -where the ":->" means that the unification variable has been -filled in with Indirect. Then when zonking alpha, it'd be nice -to short-circuit beta too, so we end up with - alpha :-> zty - beta :-> zty - gamma :-> zty -where zty is the zonked version of ty. That way, if we come across -beta later, we'll have less work to do. (And indeed the same for -alpha.) - -This is easily achieved: just overwrite (Indirect ty) with (Indirect -zty). Non-systematic perf comparisons suggest that this is a modest -win. - -But c.f Note [Sharing when zonking to Type] in GHC.Tc.Utils.Zonk. - -%************************************************************************ -%* * - Tidying -* * -************************************************************************ --} - -zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) -zonkTidyTcType env ty = do { ty' <- zonkTcType ty - ; return (tidyOpenType env ty') } - -zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType]) -zonkTidyTcTypes = zonkTidyTcTypes' [] - where zonkTidyTcTypes' zs env [] = return (env, reverse zs) - zonkTidyTcTypes' zs env (ty:tys) - = do { (env', ty') <- zonkTidyTcType env ty - ; zonkTidyTcTypes' (ty':zs) env' tys } - -zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) -zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfoAnon skol_info - ; let skol_info2 = tidySkolemInfoAnon env skol_info1 - ; return (env, GivenOrigin skol_info2) } -zonkTidyOrigin env (GivenSCOrigin skol_info sc_depth blocked) - = do { skol_info1 <- zonkSkolemInfoAnon skol_info - ; let skol_info2 = tidySkolemInfoAnon env skol_info1 - ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) } -zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp }) - = do { (env1, act') <- zonkTidyTcType env act - ; (env2, exp') <- zonkTidyTcType env1 exp - ; return ( env2, orig { uo_actual = act' - , uo_expected = exp' }) } -zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, ty2') <- zonkTidyTcType env1 ty2 - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } -zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, o1') <- zonkTidyOrigin env1 o1 - ; (env3, p2') <- zonkTidyTcType env2 p2 - ; (env4, o2') <- zonkTidyOrigin env3 o2 - ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } -zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; (env3, o1') <- zonkTidyOrigin env2 o1 - ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } -zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) - = do { (env1, pred1') <- zonkTidyTcType env pred1 - ; (env2, orig1') <- zonkTidyOrigin env1 orig1 - ; (env3, pred2') <- zonkTidyTcType env2 pred2 - ; (env4, orig2') <- zonkTidyOrigin env3 orig2 - ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } -zonkTidyOrigin env (CycleBreakerOrigin orig) - = do { (env1, orig') <- zonkTidyOrigin env orig - ; return (env1, CycleBreakerOrigin orig') } -zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) - = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst) - ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) } -zonkTidyOrigin env (WantedSuperclassOrigin pty orig) - = do { (env1, pty') <- zonkTidyTcType env pty - ; (env2, orig') <- zonkTidyOrigin env1 orig - ; return (env2, WantedSuperclassOrigin pty' orig') } -zonkTidyOrigin env orig = return (env, orig) - -zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin]) -zonkTidyOrigins = mapAccumLM zonkTidyOrigin - -zonkTidyFRRInfos :: TidyEnv - -> [FixedRuntimeRepErrorInfo] - -> TcM (TidyEnv, [FixedRuntimeRepErrorInfo]) -zonkTidyFRRInfos = go [] - where - go zs env [] = return (env, reverse zs) - go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig - , frr_info_not_concrete = mb_not_conc } : tys) - = do { (env, ty) <- zonkTidyTcType env ty - ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc - ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig - , frr_info_not_concrete = mb_not_conc } - ; go (info:zs) env tys } - - go_mb_not_conc env Nothing = return (env, Nothing) - go_mb_not_conc env (Just (tv, ty)) - = do { (env, tv) <- return $ tidyOpenTyCoVar env tv - ; (env, ty) <- zonkTidyTcType env ty - ; return (env, Just (tv, ty)) } - ----------------- -tidyCt :: TidyEnv -> Ct -> Ct --- Used only in error reporting -tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) } - -tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence - -- NB: we do not tidy the ctev_evar field because we don't - -- show it in error messages -tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty } - where - ty = ctev_pred ctev - -tidyHole :: TidyEnv -> Hole -> Hole -tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } - -tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError -tidyDelayedError env (DE_Hole hole) - = DE_Hole $ tidyHole env hole -tidyDelayedError env (DE_NotConcrete err) - = DE_NotConcrete $ tidyConcreteError env err - -tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError -tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig }) - = err { nce_frr_origin = tidyFRROrigin env frr_orig } - -tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin -tidyFRROrigin env (FixedRuntimeRepOrigin ty orig) - = FixedRuntimeRepOrigin (tidyType env ty) orig - ----------------- -tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = updateIdTypeAndMult (tidyType env) var - - -------------------------------------------------------------------------- -{- -%************************************************************************ -%* * - Representation polymorphism checks -* * -***********************************************************************-} - --- | Check that the specified type has a fixed runtime representation. --- --- If it isn't, throw a representation-polymorphism error appropriate --- for the context (as specified by the 'FixedRuntimeRepProvenance'). --- --- Unlike the other representation polymorphism checks, which can emit --- new Wanted constraints to be solved by the constraint solver, this function --- does not emit any constraints: it has enough information to immediately --- make a decision. --- --- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete -checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM () -checkTypeHasFixedRuntimeRep prov ty = - unless (typeHasFixedRuntimeRep ty) - (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) - -{- -%************************************************************************ -%* * - Error messages -* * -************************************************************************* - --} - --- See Note [Naughty quantification candidates] -naughtyQuantification :: TcType -- original type user wanted to quantify - -> TcTyVar -- naughty var - -> TyVarSet -- skolems that would escape - -> TcM a -naughtyQuantification orig_ty tv escapees - = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked - - ; escapees' <- zonkTcTyVarsToTcTyVars $ - nonDetEltsUniqSet escapees - -- we'll just be printing, so no harmful non-determinism - - ; let fvs = tyCoVarsOfTypeWellScoped orig_ty1 - env0 = tidyFreeTyCoVars emptyTidyEnv fvs - env = env0 `delTidyEnvList` escapees' - -- this avoids gratuitous renaming of the escaped - -- variables; very confusing to users! - - orig_ty' = tidyType env orig_ty1 - ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen True $ - vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' - , quotes $ ppr_tidied escapees' - , text "would escape" <+> itsOrTheir escapees' <+> text "scope" - ] - , sep [ text "if I tried to quantify" - , ppr_tidied [tv] - , text "in this type:" - ] - , nest 2 (pprTidiedType orig_ty') - , text "(Indeed, I sometimes struggle even printing this correctly," - , text " due to its ill-scoped nature.)" - ] - - ; failWithTcM (env, msg) } - -{- -************************************************************************ -* * - Checking for coercion holes -* * -************************************************************************ --} - --- | Check whether any coercion hole in a RewriterSet is still unsolved. --- Does this by recursively looking through filled coercion holes until --- one is found that is not yet filled in, at which point this aborts. -anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool -anyUnfilledCoercionHoles (RewriterSet set) - = nonDetStrictFoldUniqSet go (return False) set - -- this does not introduce non-determinism, because the only - -- monadic action is to read, and the combining function is - -- commutative - where - go :: CoercionHole -> TcM Bool -> TcM Bool - go hole m_acc = m_acc <||> check_hole hole - - check_hole :: CoercionHole -> TcM Bool - check_hole hole = do { m_co <- unpackCoercionHole_maybe hole - ; case m_co of - Nothing -> return True -- unfilled hole - Just co -> unUCHM (check_co co) } - - check_ty :: Type -> UnfilledCoercionHoleMonoid - check_co :: Coercion -> UnfilledCoercionHoleMonoid - (check_ty, _, check_co, _) = foldTyCo folder () - - folder :: TyCoFolder () UnfilledCoercionHoleMonoid - folder = TyCoFolder { tcf_view = noView - , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) - , tcf_covar = \ _ cv -> check_ty (varType cv) - , tcf_hole = \ _ -> UCHM . check_hole - , tcf_tycobinder = \ _ _ _ -> () } - -newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM Bool } - -instance Semigroup UnfilledCoercionHoleMonoid where - UCHM l <> UCHM r = UCHM (l <||> r) - -instance Monoid UnfilledCoercionHoleMonoid where - mempty = UCHM (return False) + newMetaKindVar, newMetaKindVars, + newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, + newAnonMetaTyVar, newConcreteTyVar, + cloneMetaTyVar, cloneMetaTyVarWithInfo, + newCycleBreakerTyVar, + + newMultiplicityVar, + readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, + newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + + -------------------------------- + -- Creating new evidence variables + newEvVar, newEvVars, newDict, + newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, + emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, + emitWantedEqs, + newTcEvBinds, newNoTcEvBinds, addTcEvBind, + emitNewExprHole, + + newCoercionHole, newCoercionHoleO, newVanillaCoercionHole, + fillCoercionHole, isFilledCoercionHole, + unpackCoercionHole, unpackCoercionHole_maybe, + checkCoercionHole, + + newImplication, + + -------------------------------- + -- Instantiation + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, + newMetaTyVarTyVarX, + newTyVarTyVar, cloneTyVarTyVar, + newPatSigTyVar, newSkolemTyVar, newWildCardX, + + -------------------------------- + -- Expected types + ExpType(..), ExpSigmaType, ExpRhoType, + mkCheckExpType, newInferExpType, newInferExpTypeFRR, + tcInfer, tcInferFRR, + readExpType, readExpType_maybe, readScaledExpType, + expTypeToType, scaledExpTypeToType, + checkingExpType_maybe, checkingExpType, + inferResultToType, ensureMonoType, promoteTcType, + + -------------------------------- + -- Multiplicity usage environment + tcCheckUsage, + + --------------------------------- + -- Promotion, defaulting, skolemisation + defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, + quantifyTyVars, isQuantifiableTv, + zonkAndSkolemise, skolemiseQuantifiedTyVar, + doNotQuantifyTyVars, + + candidateQTyVarsOfType, candidateQTyVarsOfKind, + candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + candidateQTyVarsWithBinders, + CandidatesQTvs(..), delCandidates, + candidateKindVars, partitionCandidates, + + ------------------------------ + -- Representation polymorphism + checkTypeHasFixedRuntimeRep, + + -- * Other HsSyn functions + mkHsDictLet, mkHsApp, + mkHsAppTy, mkHsCaseAlt, + tcShortCutLit, shortCutLit, hsOverLitName, + conLikeResTy + ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Platform + +import GHC.Driver.DynFlags +import qualified GHC.LanguageExtensions as LangExt + +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyInvisibleType, tcSubMult ) +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad -- TcType, amongst others +import GHC.Tc.Utils.TcType +import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType + +import GHC.Builtin.Names + +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.UsageEnv + +import GHC.Types.Var +import GHC.Types.Id as Id +import GHC.Types.Name +import GHC.Types.SourceText +import GHC.Types.Var.Set + +import GHC.Builtin.Types +import GHC.Types.Var.Env +import GHC.Types.Unique.Set +import GHC.Types.Basic ( TypeOrKind(..) + , NonStandardDefaultingStrategy(..) + , DefaultingStrategy(..), defaultNonStandardTyVars ) + +import GHC.Data.FastString +import GHC.Data.Bag + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Constants (debugIsOn) + +import Control.Monad +import Data.IORef +import GHC.Data.Maybe +import qualified Data.Semigroup as Semi +import GHC.Types.Name.Reader + +{- +************************************************************************ +* * + Kind variables +* * +************************************************************************ +-} + +newMetaKindVar :: TcM TcKind +newMetaKindVar + = do { details <- newMetaDetails TauTv + ; name <- newMetaTyVarName (fsLit "k") + -- All MetaKindVars are called "k" + -- They may be jiggled by tidying + ; let kv = mkTcTyVar name liftedTypeKind details + ; traceTc "newMetaKindVar" (ppr kv) + ; return (mkTyVarTy kv) } + +newMetaKindVars :: Int -> TcM [TcKind] +newMetaKindVars n = replicateM n newMetaKindVar + +{- +************************************************************************ +* * + Evidence variables; range over constraints we can abstract over +* * +************************************************************************ +-} + +newEvVars :: TcThetaType -> TcM [EvVar] +newEvVars theta = mapM newEvVar theta + +-------------- + +newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar +-- Creates new *rigid* variables for predicates +newEvVar ty = do { name <- newSysName (predTypeOccName ty) + ; return (mkLocalIdOrCoVar name ManyTy ty) } + +-- | Create a new Wanted constraint with the given 'CtLoc'. +newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence +newWantedWithLoc loc pty + = do dst <- case classifyPredType pty of + EqPred {} -> HoleDest <$> newCoercionHole loc pty + _ -> EvVarDest <$> newEvVar pty + return $ CtWanted { ctev_dest = dst + , ctev_pred = pty + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + +-- | Create a new Wanted constraint with the given 'CtOrigin', and +-- location information taken from the 'TcM' environment. +newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence +-- Deals with both equality and non-equality predicates +newWanted orig t_or_k pty + = do loc <- getCtLocM orig t_or_k + newWantedWithLoc loc pty + +-- | Create new Wanted constraints with the given 'CtOrigin', +-- and location information taken from the 'TcM' environment. +newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] +newWanteds orig = mapM (newWanted orig Nothing) + +---------------------------------------------- +-- Cloning constraints +---------------------------------------------- + +cloneWantedCtEv :: CtEvidence -> TcM CtEvidence +cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _, ctev_loc = loc }) + | isEqPrimPred pty + = do { co_hole <- newCoercionHole loc pty + ; return (ctev { ctev_dest = HoleDest co_hole }) } + | otherwise + = pprPanic "cloneWantedCtEv" (ppr pty) +cloneWantedCtEv ctev = return ctev + +cloneWanted :: Ct -> TcM Ct +cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct) + +cloneWC :: WantedConstraints -> TcM WantedConstraints +-- Clone all the evidence bindings in +-- a) the ic_bind field of any implications +-- b) the CoercionHoles of any wanted constraints +-- so that solving the WantedConstraints will not have any visible side +-- effect, /except/ from causing unifications +cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapBagM cloneWanted simples + ; implics' <- mapBagM cloneImplication implics + ; return (wc { wc_simple = simples', wc_impl = implics' }) } + +cloneImplication :: Implication -> TcM Implication +cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) + = do { binds' <- cloneEvBindsVar binds + ; inner_wanted' <- cloneWC inner_wanted + ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } + +---------------------------------------------- +-- Emitting constraints +---------------------------------------------- + +-- | Emits a new Wanted. Deals with both equalities and non-equalities. +emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm +emitWanted origin pty + = do { ev <- newWanted origin Nothing pty + ; emitSimple $ mkNonCanonical ev + ; return $ ctEvTerm ev } + +emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new wanted nominal equalities +emitWantedEqs origin pairs + | null pairs + = return () + | otherwise + = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs + +-- | Emits a new equality constraint +emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion +emitWantedEq origin t_or_k role ty1 ty2 + = do { hole <- newCoercionHoleO origin pty + ; loc <- getCtLocM origin (Just t_or_k) + ; emitSimple $ mkNonCanonical $ + CtWanted { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; return (HoleCo hole) } + where + pty = mkPrimEqPredRole role ty1 ty2 + +-- | Creates a new EvVar and immediately emits it as a Wanted. +-- No equality predicates here. +emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar +emitWantedEvVar origin ty + = do { new_cv <- newEvVar ty + ; loc <- getCtLocM origin Nothing + ; let ctev = CtWanted { ctev_pred = ty + , ctev_dest = EvVarDest new_cv + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; emitSimple $ mkNonCanonical ctev + ; return new_cv } + +emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] +emitWantedEvVars orig = mapM (emitWantedEvVar orig) + +-- | Emit a new wanted expression hole +emitNewExprHole :: RdrName -- of the hole + -> Type -> TcM HoleExprRef +emitNewExprHole occ ty + = do { u <- newUnique + ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) + ; let her = HER ref ty u + + ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) + + ; let hole = Hole { hole_sort = ExprHole her + , hole_occ = occ + , hole_ty = ty + , hole_loc = loc } + ; emitHole hole + ; return her } + +newDict :: Class -> [TcType] -> TcM DictId +newDict cls tys + = do { name <- newSysName (mkDictOcc (getOccName cls)) + ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } + +predTypeOccName :: PredType -> OccName +predTypeOccName ty = case classifyPredType ty of + ClassPred cls _ -> mkDictOcc (getOccName cls) + EqPred {} -> mkVarOccFS (fsLit "co") + IrredPred {} -> mkVarOccFS (fsLit "irred") + ForAllPred {} -> mkVarOccFS (fsLit "df") + +-- | Create a new 'Implication' with as many sensible defaults for its fields +-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do +-- /not/ have sensible defaults, so they are initialized with lazy thunks that +-- will 'panic' if forced, so one should take care to initialize these fields +-- after creation. +-- +-- This is monadic to look up the 'TcLclEnv', which is used to initialize +-- 'ic_env', and to set the -Winaccessible-code flag. See +-- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". +newImplication :: TcM Implication +newImplication + = do env <- getLclEnv + warn_inaccessible <- woptM Opt_WarnInaccessibleCode + let in_gen_code = lclEnvInGeneratedCode env + return $ + (implicationPrototype (mkCtLocEnv env)) + { ic_warn_inaccessible = warn_inaccessible && not in_gen_code } + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +newVanillaCoercionHole :: TcPredType -> TcM CoercionHole +newVanillaCoercionHole = new_coercion_hole False + +newCoercionHole :: CtLoc -> TcPredType -> TcM CoercionHole +newCoercionHole loc = newCoercionHoleO (ctLocOrigin loc) + +newCoercionHoleO :: CtOrigin -> TcPredType -> TcM CoercionHole +newCoercionHoleO (KindEqOrigin {}) = new_coercion_hole True +newCoercionHoleO _ = new_coercion_hole False + +new_coercion_hole :: Bool -> TcPredType -> TcM CoercionHole +new_coercion_hole hetero_kind pred_ty + = do { co_var <- newEvVar pred_ty + ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) + ; ref <- newMutVar Nothing + ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref + , ch_hetero_kind = hetero_kind } } + +-- | Put a value in a coercion hole +fillCoercionHole :: CoercionHole -> Coercion -> TcM () +fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do + when debugIsOn $ do + cts <- readTcRef ref + whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) + traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) + writeTcRef ref (Just co) + + +{- ********************************************************************** +* + ExpType functions +* +********************************************************************** -} + +{- Note [ExpType] +~~~~~~~~~~~~~~~~~ +An ExpType is used as the "expected type" when type-checking an expression. +An ExpType can hold a "hole" that can be filled in by the type-checker. +This allows us to have one tcExpr that works in both checking mode and +synthesis mode (that is, bidirectional type-checking). Previously, this +was achieved by using ordinary unification variables, but we don't need +or want that generality. (For example, #11397 was caused by doing the +wrong thing with unification variables.) Instead, we observe that these +holes should + +1. never be nested +2. never appear as the type of a variable +3. be used linearly (never be duplicated) + +By defining ExpType, separately from Type, we can achieve goals 1 and 2 +statically. + +See also [wiki:typechecking] + +Note [TcLevel of ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data G a where + MkG :: G Bool + + foo MkG = True + +This is a classic untouchable-variable / ambiguous GADT return type +scenario. But, with ExpTypes, we'll be inferring the type of the RHS. +We thus must track a TcLevel in an Inferring ExpType. If we try to +fill the ExpType and find that the TcLevels don't work out, we fill +the ExpType with a tau-tv at the low TcLevel, hopefully to be worked +out later by some means -- see fillInferResult, and Note [fillInferResult] + +This behaviour triggered in test gadt/gadt-escape1. + +Note [FixedRuntimeRep context in ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, we want to be sure that we fill an ExpType with a type +that has a syntactically fixed RuntimeRep (in the sense of +Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). + +Example: + + pattern S a = (a :: (T :: TYPE R)) + +We have to infer a type for `a` which has a syntactically fixed RuntimeRep. +When it comes time to filling in the inferred type, we do the appropriate +representation-polymorphism check, much like we do a level check +as explained in Note [TcLevel of ExpType]. + +See test case T21325. +-} + +-- actual data definition is in GHC.Tc.Utils.TcType + +newInferExpType :: TcM ExpType +newInferExpType = new_inferExpType Nothing + +newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR +newInferExpTypeFRR frr_orig + = do { th_stage <- getStage + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | Brack _ (TcPending {}) <- th_stage + -> new_inferExpType Nothing + + | otherwise + -> new_inferExpType (Just frr_orig) } + +new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType +new_inferExpType mb_frr_orig + = do { u <- newUnique + ; tclvl <- getTcLevel + ; traceTc "newInferExpType" (ppr u <+> ppr tclvl) + ; ref <- newMutVar Nothing + ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl + , ir_ref = ref + , ir_frr = mb_frr_orig })) } + +-- | Extract a type out of an ExpType, if one exists. But one should always +-- exist. Unless you're quite sure you know what you're doing. +readExpType_maybe :: MonadIO m => ExpType -> m (Maybe TcType) +readExpType_maybe (Check ty) = return (Just ty) +readExpType_maybe (Infer (IR { ir_ref = ref})) = liftIO $ readIORef ref +{-# INLINEABLE readExpType_maybe #-} + +-- | Same as readExpType, but for Scaled ExpTypes +readScaledExpType :: MonadIO m => Scaled ExpType -> m (Scaled Type) +readScaledExpType (Scaled m exp_ty) + = do { ty <- readExpType exp_ty + ; return (Scaled m ty) } +{-# INLINEABLE readScaledExpType #-} + +-- | Extract a type out of an ExpType. Otherwise, panics. +readExpType :: MonadIO m => ExpType -> m TcType +readExpType exp_ty + = do { mb_ty <- readExpType_maybe exp_ty + ; case mb_ty of + Just ty -> return ty + Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } +{-# INLINEABLE readExpType #-} + +scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType) +scaledExpTypeToType (Scaled m exp_ty) + = do { ty <- expTypeToType exp_ty + ; return (Scaled m ty) } + +-- | Extracts the expected type if there is one, or generates a new +-- TauTv if there isn't. +expTypeToType :: ExpType -> TcM TcType +expTypeToType (Check ty) = return ty +expTypeToType (Infer inf_res) = inferResultToType inf_res + +inferResultToType :: InferResult -> TcM Type +inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl + , ir_ref = ref + , ir_frr = mb_frr }) + = do { mb_inferred_ty <- readTcRef ref + ; tau <- case mb_inferred_ty of + Just ty -> do { ensureMonoType ty + -- See Note [inferResultToType] + ; return ty } + Nothing -> do { tau <- new_meta + ; writeMutVar ref (Just tau) + ; return tau } + ; traceTc "Forcing ExpType to be monomorphic:" + (ppr u <+> text ":=" <+> ppr tau) + ; return tau } + where + -- See Note [TcLevel of ExpType] + new_meta = case mb_frr of + Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } + Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr + ; return tau } + +{- Note [inferResultToType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +expTypeToType and inferResultType convert an InferResult to a monotype. +It must be a monotype because if the InferResult isn't already filled in, +we fill it in with a unification variable (hence monotype). So to preserve +order-independence we check for mono-type-ness even if it *is* filled in +already. + +See also Note [TcLevel of ExpType] above, and +Note [fillInferResult] in GHC.Tc.Utils.Unify. +-} + +-- | Infer a type using a fresh ExpType +-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" +-- +-- Use 'tcInferFRR' if you require the type to have a fixed +-- runtime representation. +tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +tcInfer = tc_infer Nothing + +-- | Like 'tcInfer', except it ensures that the resulting type +-- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in +-- GHC.Tc.Utils.Concrete. +tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) +tcInferFRR frr_orig = tc_infer (Just frr_orig) + +tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +tc_infer mb_frr tc_check + = do { res_ty <- new_inferExpType mb_frr + ; result <- tc_check res_ty + ; res_ty <- readExpType res_ty + ; return (result, res_ty) } + +{- ********************************************************************* +* * + Promoting types +* * +********************************************************************* -} + +ensureMonoType :: TcType -> TcM () +-- Assuming that the argument type is of kind (TYPE r), +-- ensure that it is a /monotype/ +-- If it is not a monotype we can see right away (since unification +-- variables and type-function applications stand for monotypes), but +-- we emit a Wanted equality just to delay the error message until later +ensureMonoType res_ty + | isTauTy res_ty -- isTauTy doesn't need zonking or anything + = return () + | otherwise + = do { mono_ty <- newOpenFlexiTyVarTy + ; _co <- unifyInvisibleType res_ty mono_ty + ; return () } + +promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) +-- See Note [Promoting a type] +-- See also Note [fillInferResult] +-- promoteTcType level ty = (co, ty') +-- * Returns ty' whose max level is just 'level' +-- and whose kind is ~# to the kind of 'ty' +-- and whose kind has form TYPE rr +-- * and co :: ty ~ ty' +-- * and emits constraints to justify the coercion +-- +-- NB: we expect that 'ty' has already kind (TYPE rr) for +-- some rr::RuntimeRep. It is, after all, the type of a term. +promoteTcType dest_lvl ty + = do { cur_lvl <- getTcLevel + ; if (cur_lvl `sameDepthAs` dest_lvl) + then return (mkNomReflCo ty, ty) + else promote_it } + where + promote_it :: TcM (TcCoercion, TcType) + promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty + -- where alpha and rr are fresh and from level dest_lvl + = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy + ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) + ; co <- unifyInvisibleType ty prom_ty + ; return (co, prom_ty) } + +{- Note [Promoting a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12427) + + data T where + MkT :: (Int -> Int) -> a -> T + + h y = case y of MkT v w -> v + +We'll infer the RHS type with an expected type ExpType of + (IR { ir_lvl = l, ir_ref = ref, ... ) +where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern +match will increase the level, so we'll end up in tcSubType, trying to +unify the type of v, + v :: Int -> Int +with the expected type. But this attempt takes place at level (l+1), +rightly so, since v's type could have mentioned existential variables, +(like w's does) and we want to catch that. + +So we + - create a new meta-var alpha[l+1] + - fill in the InferRes ref cell 'ref' with alpha + - emit an equality constraint, thus + [W] alpha[l+1] ~ (Int -> Int) + +That constraint will float outwards, as it should, unless v's +type mentions a skolem-captured variable. + +This approach fails if v has a higher rank type; see +Note [Promotion and higher rank types] + + +Note [Promotion and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If v had a higher-rank type, say v :: (forall a. a->a) -> Int, +then we'd emit an equality + [W] alpha[l+1] ~ ((forall a. a->a) -> Int) +which will sadly fail because we can't unify a unification variable +with a polytype. But there is nothing really wrong with the program +here. + +We could just about solve this by "promote the type" of v, to expose +its polymorphic "shape" while still leaving constraints that will +prevent existential escape. But we must be careful! Exposing +the "shape" of the type is precisely what we must NOT do under +a GADT pattern match! So in this case we might promote the type +to + (forall a. a->a) -> alpha[l+1] +and emit the constraint + [W] alpha[l+1] ~ Int +Now the promoted type can fill the ref cell, while the emitted +equality can float or not, according to the usual rules. + +But that's not quite right! We are exposing the arrow! We could +deal with that too: + (forall a. mu[l+1] a a) -> alpha[l+1] +with constraints + [W] alpha[l+1] ~ Int + [W] mu[l+1] ~ (->) +Here we abstract over the '->' inside the forall, in case that +is subject to an equality constraint from a GADT match. + +Note that we kept the outer (->) because that's part of +the polymorphic "shape". And because of impredicativity, +GADT matches can't give equalities that affect polymorphic +shape. + +This reasoning just seems too complicated, so I decided not +to do it. These higher-rank notes are just here to record +the thinking. +-} + + +{- ********************************************************************* +* * + MetaTvs (meta type variables; mutable) +* * +********************************************************************* -} + +{- Note [TyVarTv] +~~~~~~~~~~~~~~~~~ +A TyVarTv can unify with type *variables* only, including other TyVarTvs and +skolems. They are used in two places: + +1. In kind signatures, see GHC.Tc.TyCl + Note [Inferring kinds for type declarations] + and Note [Using TyVarTvs for kind-checking GADTs] + +2. In partial type signatures. See GHC.Tc.Types + Note [Quantified variables in partial type signatures] + +Sometimes, they can unify with type variables that the user would +rather keep distinct; see #11203 for an example. So, any client of +this function needs to either allow the TyVarTvs to unify with each +other or check that they don't. In the case of (1) the check is done +in GHC.Tc.TyCl.swizzleTcTyConBndrs. In case of (2) it's done by +findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Historical note: Before #15050 this (under the name SigTv) was also +used for ScopedTypeVariables in patterns, to make sure these type +variables only refer to other type variables, but this restriction was +dropped, and ScopedTypeVariables can now refer to full types (GHC +Proposal 29). +-} + +newMetaTyVarName :: FastString -> TcM Name +-- Makes a /System/ Name, which is eagerly eliminated by +-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +-- GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) +newMetaTyVarName str + = newSysName (mkTyVarOccFS str) + +cloneMetaTyVarName :: Name -> TcM Name +cloneMetaTyVarName name + = newSysName (nameOccName name) + -- See Note [Name of an instantiated type variable] + +{- Note [Name of an instantiated type variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we give a unification variable a System Name, which +influences the way it is tidied; see TypeRep.tidyTyVarBndr. +-} + +metaInfoToTyVarName :: MetaInfo -> FastString +metaInfoToTyVarName meta_info = + case meta_info of + TauTv -> fsLit "t" + TyVarTv -> fsLit "a" + RuntimeUnkTv -> fsLit "r" + CycleBreakerTv -> fsLit "b" + ConcreteTv {} -> fsLit "c" + +newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar +newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi + +newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newNamedAnonMetaTyVar tyvar_name meta_info kind + + = do { name <- newMetaTyVarName tyvar_name + ; details <- newMetaDetails meta_info + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newAnonMetaTyVar" (ppr tyvar) + ; return tyvar } + +-- makes a new skolem tv +newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar +newSkolemTyVar skol_info name kind + = do { lvl <- getTcLevel + ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } + +newTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Does not clone a fresh unique +newTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newTyVarTyVar" (ppr tyvar) + ; return tyvar } + +cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Clones a fresh unique +cloneTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar, which makes a SystemName + -- We want to keep the original more user-friendly Name + -- In practical terms that means that in error messages, + -- when the Name is tidied we get 'a' rather than 'a0' + ; traceTc "cloneTyVarTyVar" (ppr tyvar) + ; return tyvar } + +-- | Create a new metavariable, of the given kind, which can only be unified +-- with a concrete type. +-- +-- Invariant: the kind must be concrete, as per Note [ConcreteTv]. +-- This is checked with an assertion. +newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin + -> FastString -> TcKind -> TcM TcTyVar +newConcreteTyVar reason fs kind + = assertPpr (isConcreteType kind) assert_msg $ + newNamedAnonMetaTyVar fs (ConcreteTv reason) kind + where + assert_msg = text "newConcreteTyVar: non-concrete kind" <+> ppr kind + +newPatSigTyVar :: Name -> Kind -> TcM TcTyVar +newPatSigTyVar name kind + = do { details <- newMetaDetails TauTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar; + -- same reasoning as in newTyVarTyVar + ; traceTc "newPatSigTyVar" (ppr tyvar) + ; return tyvar } + +cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar +-- Make a fresh MetaTyVar, basing the name +-- on that of the supplied TyVar +cloneAnonMetaTyVar info tv kind + = do { details <- newMetaDetails info + ; name <- cloneMetaTyVarName (tyVarName tv) + ; let tyvar = mkTcTyVar name kind details + ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) + ; return tyvar } + +-- Make a new CycleBreakerTv. See Note [Type equality cycles] +-- in GHC.Tc.Solver.Equality +newCycleBreakerTyVar :: TcKind -> TcM TcTyVar +newCycleBreakerTyVar kind + = do { details <- newMetaDetails CycleBreakerTv + ; name <- newMetaTyVarName (fsLit "cbv") + ; return (mkTcTyVar name kind details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; return (MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails +newTauTvDetailsAtLevel tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = TauTv + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails +newConcreteTvDetailsAtLevel conc_orig tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = ConcreteTv conc_orig + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = assert (isTcTyVar tv) $ + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + tyvar = mkTcTyVar name' (tyVarKind tv) details' + ; traceTc "cloneMetaTyVar" (ppr tyvar) + ; return tyvar } + +cloneMetaTyVarWithInfo :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcTyVar +cloneMetaTyVarWithInfo info tc_lvl tv + = assert (isTcTyVar tv) $ + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tc_lvl } + tyvar = mkTcTyVar name' (tyVarKind tv) details + ; traceTc "cloneMetaTyVarWithInfo" (ppr tyvar) + ; return tyvar } + +-- Works for both type and kind variables +readMetaTyVar :: MonadIO m => TyVar -> m MetaDetails +readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $ + liftIO $ readIORef (metaTyVarRef tyvar) +{-# SPECIALISE readMetaTyVar :: TyVar -> TcM MetaDetails #-} +{-# SPECIALISE readMetaTyVar :: TyVar -> ZonkM MetaDetails #-} + +isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) +isFilledMetaTyVar_maybe tv +-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails +-- at the moment (Jan 22) + | isTcTyVar tv + , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { cts <- readTcRef ref + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + | otherwise + = return Nothing + +isFilledMetaTyVar :: TyVar -> TcM Bool +-- True of a filled-in (Indirect) meta type variable +isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv + +isUnfilledMetaTyVar :: TyVar -> TcM Bool +-- True of a un-filled-in (Flexi) meta type variable +-- NB: Not the opposite of isFilledMetaTyVar +isUnfilledMetaTyVar tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { details <- readMutVar ref + ; return (isFlexi details) } + | otherwise = return False + +{- +************************************************************************ +* * + MetaTvs: TauTvs +* * +************************************************************************ + +Note [Never need to instantiate coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With coercion variables sloshing around in types, it might seem that we +sometimes need to instantiate coercion variables. This would be problematic, +because coercion variables inhabit unboxed equality (~#), and the constraint +solver thinks in terms only of boxed equality (~). The solution is that +we never need to instantiate coercion variables in the first place. + +The tyvars that we need to instantiate come from the types of functions, +data constructors, and patterns. These will never be quantified over +coercion variables, except for the special case of the promoted Eq#. But, +that can't ever appear in user code, so we're safe! +-} + + +newMultiplicityVar :: TcM TcType +newMultiplicityVar = newFlexiTyVarTy multiplicityTy + +newFlexiTyVar :: Kind -> TcM TcTyVar +newFlexiTyVar kind = newAnonMetaTyVar TauTv kind + +-- | Create a new flexi ty var with a specific name +newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar +newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind + +newFlexiTyVarTy :: Kind -> TcM TcType +newFlexiTyVarTy kind = do + tc_tyvar <- newFlexiTyVar kind + return (mkTyVarTy tc_tyvar) + +newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] +newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) + +newOpenTypeKind :: TcM TcKind +newOpenTypeKind + = do { rr <- newFlexiTyVarTy runtimeRepTy + ; return (mkTYPEapp rr) } + +-- | Create a tyvar that can be a lifted or unlifted type. +-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh +newOpenFlexiTyVarTy :: TcM TcType +newOpenFlexiTyVarTy + = do { tv <- newOpenFlexiTyVar + ; return (mkTyVarTy tv) } + +newOpenFlexiTyVar :: TcM TcTyVar +newOpenFlexiTyVar + = do { kind <- newOpenTypeKind + ; newFlexiTyVar kind } + +newOpenBoxedTypeKind :: TcM TcKind +newOpenBoxedTypeKind + = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) + ; let rr = mkTyConApp boxedRepDataConTyCon [lev] + ; return (mkTYPEapp rr) } + +newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar]) +-- Instantiate with META type variables +-- Note that this works for a sequence of kind, type, and coercion variables +-- variables. Eg [ (k:*), (a:k->k) ] +-- Gives [ (k7:*), (a8:k7->k7) ] +newMetaTyVars = newMetaTyVarsX emptySubst + -- emptySubst has an empty in-scope set, but that's fine here + -- Since the tyvars are freshly made, they cannot possibly be + -- captured by any existing for-alls. + +newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- Just like newMetaTyVars, but start with an existing substitution. +newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst + +newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +-- Make a new unification variable tyvar whose Name and Kind come from +-- an existing TyVar. We substitute kind variables in the kind. +newMetaTyVarX = new_meta_tv_x TauTv + +newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +-- Just like newMetaTyVarX, but make a TyVarTv +newMetaTyVarTyVarX = new_meta_tv_x TyVarTv + +newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +newWildCardX subst tv + = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) + ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } + +new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar) +new_meta_tv_x info subst tv + = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind + ; let subst1 = extendTvSubstWithClone subst tv new_tv + ; return (subst1, new_tv) } + where + substd_kind = substTyUnchecked subst (tyVarKind tv) + -- NOTE: #12549 is fixed so we could use + -- substTy here, but the tc_infer_args problem + -- is not yet fixed so leaving as unchecked for now. + -- OLD NOTE: + -- Unchecked because we call newMetaTyVarX from + -- tcInstTyBinder, which is called from tcInferTyApps + -- which does not yet take enough trouble to ensure + -- the in-scope set is right; e.g. #12785 trips + -- if we use substTy here + +newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType +newMetaTyVarTyAtLevel tc_lvl kind + = do { details <- newTauTvDetailsAtLevel tc_lvl + ; name <- newMetaTyVarName (fsLit "p") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +newConcreteTyVarTyAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType +newConcreteTyVarTyAtLevel conc_orig tc_lvl kind + = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl + ; name <- newMetaTyVarName (fsLit "c") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +{- ********************************************************************* +* * + Finding variables to quantify over +* * +********************************************************************* -} + +{- Note [Dependent type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell type inference we quantify over type variables; but we only +quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds +we default the kind variables to *. + +So, to support this defaulting, and only for that reason, when +collecting the free vars of a type (in candidateQTyVarsOfType and friends), +prior to quantifying, we must keep the type and kind variables separate. + +But what does that mean in a system where kind variables /are/ type +variables? It's a fairly arbitrary distinction based on how the +variables appear: + + - "Kind variables" appear in the kind of some other free variable + or in the kind of a locally quantified type variable + (forall (a :: kappa). ...) or in the kind of a coercion + (a |> (co :: kappa1 ~ kappa2)). + + These are the ones we default to * if -XPolyKinds is off + + - "Type variables" are all free vars that are not kind variables + +E.g. In the type T k (a::k) + 'k' is a kind variable, because it occurs in the kind of 'a', + even though it also appears at "top level" of the type + 'a' is a type variable, because it doesn't + +We gather these variables using a CandidatesQTvs record: + DV { dv_kvs: Variables free in the kind of a free type variable + or of a forall-bound type variable + , dv_tvs: Variables syntactically free in the type } + +So: dv_kvs are the kind variables of the type + (dv_tvs - dv_kvs) are the type variable of the type + +Note that + +* A variable can occur in both. + T k (x::k) The first occurrence of k makes it + show up in dv_tvs, the second in dv_kvs + +* We include any coercion variables in the "dependent", + "kind-variable" set because we never quantify over them. + +* The "kind variables" might depend on each other; e.g + (k1 :: k2), (k2 :: *) + The "type variables" do not depend on each other; if + one did, it'd be classified as a kind variable! + +Note [CandidatesQTvs determinism and order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Determinism: when we quantify over type variables we decide the + order in which they appear in the final type. Because the order of + type variables in the type can end up in the interface file and + affects some optimizations like worker-wrapper, we want this order to + be deterministic. + + To achieve that we use deterministic sets of variables that can be + converted to lists in a deterministic order. For more information + about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +* Order: as well as being deterministic, we use an + accumulating-parameter style for candidateQTyVarsOfType so that we + add variables one at a time, left to right. That means we tend to + produce the variables in left-to-right order. This is just to make + it bit more predictable for the programmer. + +Note [Naughty quantification candidates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14880, dependent/should_compile/T14880-2), suppose +we are trying to generalise this type: + + forall arg. ... (alpha[tau]:arg) ... + +We have a metavariable alpha whose kind mentions a skolem variable +bound inside the very type we are generalising. +This can arise while type-checking a user-written type signature +(see the test case for the full code). + +We cannot generalise over alpha! That would produce a type like + forall {a :: arg}. forall arg. ...blah... +The fact that alpha's kind mentions arg renders it completely +ineligible for generalisation. + +However, we are not going to learn any new constraints on alpha, +because its kind isn't even in scope in the outer context (but see Wrinkle). +So alpha is entirely unconstrained. + +What then should we do with alpha? During generalization, every +metavariable is either (A) promoted, (B) generalized, or (C) zapped +(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType). + + * We can't generalise it. + * We can't promote it, because its kind prevents that + * We can't simply leave it be, because this type is about to + go into the typing environment (as the type of some let-bound + variable, say), and then chaos erupts when we try to instantiate. + +Previously, we zapped it to Any. This worked, but it had the unfortunate +effect of causing Any sometimes to appear in error messages. If this +kind of signature happens, the user probably has made a mistake -- no +one really wants Any in their types. So we now error. This must be +a hard error (failure in the monad) to avoid other messages from mentioning +Any. + +We do this eager erroring in candidateQTyVars, which always precedes +generalisation, because at that moment we have a clear picture of what +skolems are in scope within the type itself (e.g. that 'forall arg'). + +This change is inspired by and described in Section 7.2 of "Kind Inference +for Datatypes", POPL'20. + +NB: this is all rather similar to, but sadly not the same as + Note [Error on unconstrained meta-variables] + +Wrinkle: + +We must make absolutely sure that alpha indeed is not from an outer +context. (Otherwise, we might indeed learn more information about it.) +This can be done easily: we just check alpha's TcLevel. That level +must be strictly greater than the ambient TcLevel in order to treat it +as naughty. We say "strictly greater than" because the call to +candidateQTyVars is made outside the bumped TcLevel, as stated in the +comment to candidateQTyVarsOfType. The level check is done in go_tv in +collect_cand_qtvs. Skipping this check caused #16517. + +-} + +data CandidatesQTvs + -- See Note [Dependent type variables] + -- See Note [CandidatesQTvs determinism and order] + -- + -- Invariants: + -- * All variables are fully zonked, including their kinds + -- * All variables are at a level greater than the ambient level + -- See Note [Use level numbers for quantification] + -- + -- This *can* contain skolems. For example, in `data X k :: k -> Type` + -- we need to know that the k is a dependent variable. This is done + -- by collecting the candidates in the kind after skolemising. It also + -- comes up when generalizing a associated type instance, where instance + -- variables are skolems. (Recall that associated type instances are generalized + -- independently from their enclosing class instance, and the associated + -- type instance may be generalized by more, fewer, or different variables + -- than the class instance.) + -- + = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) + , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) + -- A variable may appear in both sets + -- E.g. T k (x::k) The first occurrence of k makes it + -- show up in dv_tvs, the second in dv_kvs + -- See Note [Dependent type variables] + + , dv_cvs :: CoVarSet + -- These are covars. Included only so that we don't repeatedly + -- look at covars' kinds in accumulator. Not used by quantifyTyVars. + } + +instance Semi.Semigroup CandidatesQTvs where + (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) + <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) + = DV { dv_kvs = kv1 `unionDVarSet` kv2 + , dv_tvs = tv1 `unionDVarSet` tv2 + , dv_cvs = cv1 `unionVarSet` cv2 } + +instance Monoid CandidatesQTvs where + mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } + mappend = (Semi.<>) + +instance Outputable CandidatesQTvs where + ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) + = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs + , text "dv_tvs =" <+> ppr tvs + , text "dv_cvs =" <+> ppr cvs ]) + +isEmptyCandidates :: CandidatesQTvs -> Bool +isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) + = isEmptyDVarSet kvs && isEmptyDVarSet tvs + +-- | Extract out the kind vars (in order) and type vars (in order) from +-- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping +-- the lists separate is important only in the -XNoPolyKinds case. +candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar]) +candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) + = (dep_kvs, nondep_tvs) + where + dep_kvs = scopedSort $ dVarSetElems dep_kv_set + -- scopedSort: put the kind variables into + -- well-scoped order. + -- E.g. [k, (a::k)] not the other way round + + nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) + -- See Note [Dependent type variables] + -- The `minus` dep_tkvs removes any kind-level vars + -- e.g. T k (a::k) Since k appear in a kind it'll + -- be in dv_kvs, and is dependent. So remove it from + -- dv_tvs which will also contain k + -- NB kinds of tvs are already zonked + +candidateKindVars :: CandidatesQTvs -> TyVarSet +candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) + +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } + +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) +-- The selected TyVars are returned as a non-deterministic TyVarSet +partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred + = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) + where + (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs + (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs + extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs + +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs +-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars +-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose +-- of Note [Naughty quantification candidates]. Why? +-- Because we are going to scoped-sort the quantified variables +-- in among the tvs +candidateQTyVarsWithBinders bound_tvs ty + = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) + ; cur_lvl <- getTcLevel + ; all_tvs <- collect_cand_qtvs ty False cur_lvl emptyVarSet kvs ty + ; return (all_tvs `delCandidates` bound_tvs) } + +-- | Gathers free variables to use as quantification candidates (in +-- 'quantifyTyVars'). This might output the same var +-- in both sets, if it's used in both a type and a kind. +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +-- See Note [CandidatesQTvs determinism and order] +-- See Note [Dependent type variables] +candidateQTyVarsOfType :: TcType -- not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfType ty + = do { cur_lvl <- getTcLevel + ; collect_cand_qtvs ty False cur_lvl emptyVarSet mempty ty } + +-- | Like 'candidateQTyVarsOfType', but over a list of types +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs +candidateQTyVarsOfTypes tys + = do { cur_lvl <- getTcLevel + ; foldlM (\acc ty -> collect_cand_qtvs ty False cur_lvl emptyVarSet acc ty) + mempty tys } + +-- | Like 'candidateQTyVarsOfType', but consider every free variable +-- to be dependent. This is appropriate when generalizing a *kind*, +-- instead of a type. (That way, -XNoPolyKinds will default the variables +-- to Type.) +candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKind ty + = do { cur_lvl <- getTcLevel + ; collect_cand_qtvs ty True cur_lvl emptyVarSet mempty ty } + +candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKinds tys + = do { cur_lvl <- getTcLevel + ; foldM (\acc ty -> collect_cand_qtvs ty True cur_lvl emptyVarSet acc ty) + mempty tys } + +collect_cand_qtvs + :: TcType -- Original type that we started recurring into; for errors + -> Bool -- True <=> consider every fv in Type to be dependent + -> TcLevel -- Current TcLevel; collect only tyvars whose level is greater + -> VarSet -- Bound variables (locals only) + -> CandidatesQTvs -- Accumulating parameter + -> Type -- Not necessarily zonked + -> TcM CandidatesQTvs + +-- Key points: +-- * Looks through meta-tyvars as it goes; +-- no need to zonk in advance +-- +-- * Needs to be monadic anyway, because it handles naughty +-- quantification; see Note [Naughty quantification candidates] +-- +-- * Returns fully-zonked CandidateQTvs, including their kinds +-- so that subsequent dependency analysis (to build a well +-- scoped telescope) works correctly + +collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty + = go dvs ty + where + is_bound tv = tv `elemVarSet` bound + + ----------------- + go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs + -- Uses accumulating-parameter style + go dv (AppTy t1 t2) = foldlM go dv [t1, t2] + go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys + go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] + go dv (LitTy {}) = return dv + go dv (CastTy ty co) = do { dv1 <- go dv ty + ; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co } + go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty cur_lvl bound dv co + + go dv (TyVarTy tv) + | is_bound tv = return dv + | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv + ; case m_contents of + Just ind_ty -> go dv ind_ty + Nothing -> go_tv dv tv } + + go dv (ForAllTy (Bndr tv _) ty) + = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv (tyVarKind tv) + ; collect_cand_qtvs orig_ty is_dep cur_lvl (bound `extendVarSet` tv) dv1 ty } + + -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha). + -- Tested in polykinds/NestedProxies. + -- We just might get this wrong in AppTy, but I don't think that's possible + -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need + -- to look at kinds. + go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys) + = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr) + cur_lvl bound dv ty + ; go_tc_args dv1 tc_bndrs tys } + go_tc_args dv _bndrs tys -- _bndrs might be non-empty: undersaturation + -- tys might be non-empty: oversaturation + -- either way, the foldlM is correct + = foldlM go dv tys + + ----------------- + go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv + | tcTyVarLevel tv <= cur_lvl + = return dv -- This variable is from an outer context; skip + -- See Note [Use level numbers for quantification] + + | case tcTyVarDetails tv of + SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl + _ -> False + = return dv -- Skip inner skolems + -- This only happens for erroneous program with bad telescopes + -- e.g. BadTelescope2: forall a k (b :: k). SameKind a b + -- We have (a::k), and at the outer we don't want to quantify + -- over the already-quantified skolem k. + -- (Apparently we /do/ want to quantify over skolems whose level sk_lvl is + -- sk_lvl > cur_lvl; you get lots of failures otherwise. A battle for another day.) + + | tv `elemDVarSet` kvs + = return dv -- We have met this tyvar already + + | not is_dep + , tv `elemDVarSet` tvs + = return dv -- We have met this tyvar already + + | otherwise + = do { tv_kind <- liftZonkM $ zonkTcType (tyVarKind tv) + -- This zonk is annoying, but it is necessary, both to + -- ensure that the collected candidates have zonked kinds + -- (#15795) and to make the naughty check + -- (which comes next) works correctly + + ; let tv_kind_vars = tyCoVarsOfType tv_kind + ; if | intersectsVarSet bound tv_kind_vars + -- the tyvar must not be from an outer context, but we have + -- already checked for this. + -- See Note [Naughty quantification candidates] + -> do { traceTc "Naughty quantifier" $ + vcat [ ppr tv <+> dcolon <+> ppr tv_kind + , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) + , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] + + ; let escapees = intersectVarSet bound tv_kind_vars + ; naughtyQuantification orig_ty tv escapees } + + | otherwise + -> do { let tv' = tv `setTyVarKind` tv_kind + dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } + | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } + -- See Note [Order of accumulation] + + -- See Note [Recurring into kinds for candidateQTyVars] + ; collect_cand_qtvs orig_ty True cur_lvl bound dv' tv_kind } } + +collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors + -> TcLevel + -> VarSet -- bound variables + -> CandidatesQTvs -> Coercion + -> TcM CandidatesQTvs +collect_cand_qtvs_co orig_ty cur_lvl bound = go_co + where + go_co dv (Refl ty) = collect_cand_qtvs orig_ty True cur_lvl bound dv ty + go_co dv (GRefl _ ty mco) = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty + ; go_mco dv1 mco } + go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos + go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2] + go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos + go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos + go_co dv (UnivCo prov _ t1 t2) = do { dv1 <- go_prov dv prov + ; dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t1 + ; collect_cand_qtvs orig_ty True cur_lvl bound dv2 t2 } + go_co dv (SymCo co) = go_co dv co + go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (SelCo _ co) = go_co dv co + go_co dv (LRCo _ co) = go_co dv co + go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (KindCo co) = go_co dv co + go_co dv (SubCo co) = go_co dv co + + go_co dv (HoleCo hole) + = do m_co <- unpackCoercionHole_maybe hole + case m_co of + Just co -> go_co dv co + Nothing -> go_cv dv (coHoleCoVar hole) + + go_co dv (CoVarCo cv) = go_cv dv cv + + go_co dv (ForAllCo tcv kind_co co) + = do { dv1 <- go_co dv kind_co + ; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co } + + go_mco dv MRefl = return dv + go_mco dv (MCo co) = go_co dv co + + go_prov dv (PhantomProv co) = go_co dv co + go_prov dv (ProofIrrelProv co) = go_co dv co + go_prov dv (PluginProv _) = return dv + go_prov dv (CorePrepProv _) = return dv + + go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs + go_cv dv@(DV { dv_cvs = cvs }) cv + | is_bound cv = return dv + | cv `elemVarSet` cvs = return dv + + -- See Note [Recurring into kinds for candidateQTyVars] + | otherwise = collect_cand_qtvs orig_ty True cur_lvl bound + (dv { dv_cvs = cvs `extendVarSet` cv }) + (idType cv) + + is_bound tv = tv `elemVarSet` bound + +{- Note [Order of accumulation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might be tempted (like I was) to use unitDVarSet and mappend +rather than extendDVarSet. However, the union algorithm for +deterministic sets depends on (roughly) the size of the sets. The +elements from the smaller set end up to the right of the elements from +the larger one. When sets are equal, the left-hand argument to +`mappend` goes to the right of the right-hand argument. + +In our case, if we use unitDVarSet and mappend, we learn that the free +variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify +over them in that order. (The a comes after the b because we union the +singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, +the size criterion works to our advantage.) This is just annoying to +users, so I use `extendDVarSet`, which unambiguously puts the new +element to the right. + +Note that the unitDVarSet/mappend implementation would not be wrong +against any specification -- just suboptimal and confounding to users. + +Note [Recurring into kinds for candidateQTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying +attention to the end of the Note about using an empty bound set when +traversing a variable's kind. + +That Note concludes with the recommendation that we empty out the bound +set when recurring into the kind of a type variable. Yet, we do not do +this here. I have two tasks in order to convince you that this code is +right. First, I must show why it is safe to ignore the reasoning in that +Note. Then, I must show why is is necessary to contradict the reasoning in +that Note. + +Why it is safe: There can be no +shadowing in the candidateQ... functions: they work on the output of +type inference, which is seeded by the renamer and its insistence to +use different Uniques for different variables. (In contrast, the Core +functions work on the output of optimizations, which may introduce +shadowing.) Without shadowing, the problem studied by +Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. + +Why it is necessary: +Wiping the bound set would be just plain wrong here. Consider + + forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) + +We really don't want to think k1 and k2 are free here. (It's true that we'll +never be able to fill in `hole`, but we don't want to go off the rails just +because we have an insoluble coercion hole.) So: why is it wrong to wipe +the bound variables here but right in Core? Because the final statement +in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not +every variable is either free or bound. A variable can be a hole, too! +The reasoning in that Note then breaks down. + +And the reasoning applies just as well to free non-hole variables, so we +retain the bound set always. + +-} + +{- ********************************************************************* +* * + Quantification +* * +************************************************************************ + +Note [quantifyTyVars] +~~~~~~~~~~~~~~~~~~~~~ +quantifyTyVars is given the free vars of a type that we +are about to wrap in a forall. + +It takes these free type/kind variables (partitioned into dependent and +non-dependent variables) skolemises metavariables with a TcLevel greater +than the ambient level (see Note [Use level numbers for quantification]). + +* This function distinguishes between dependent and non-dependent + variables only to keep correct defaulting behavior with -XNoPolyKinds. + With -XPolyKinds, it treats both classes of variables identically. + +* quantifyTyVars never quantifies over + - a coercion variable (or any tv mentioned in the kind of a covar) + - a runtime-rep variable + +Note [Use level numbers for quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The level numbers assigned to metavariables are very useful. Not only +do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType), +but they also allow us to determine which variables to +generalise. The rule is this: + + When generalising, quantify only metavariables with a TcLevel greater + than the ambient level. + +This works because we bump the level every time we go inside a new +source-level construct. In a traditional generalisation algorithm, we +would gather all free variables that aren't free in an environment. +However, if a variable is in that environment, it will always have a lower +TcLevel: it came from an outer scope. So we can replace the "free in +environment" check with a level-number check. + +Here is an example: + + f x = x + (z True) + where + z y = x * x + +We start by saying (x :: alpha[1]). When inferring the type of z, we'll +quickly discover that z :: alpha[1]. But it would be disastrous to +generalise over alpha in the type of z. So we need to know that alpha +comes from an outer environment. By contrast, the type of y is beta[2], +and we are free to generalise over it. What's the difference between +alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for +generalisation, and so we generalise it. alpha[1] does not, and so +we leave it alone. + +Note that not *every* variable with a higher level will get +generalised, either due to the monomorphism restriction or other +quirks. See, for example, the code in GHC.Tc.Solver.decideMonoTyVars +and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude +certain otherwise-eligible variables from being generalised. + +Using level numbers for quantification is implemented in the candidateQTyVars... +functions, by adding only those variables with a level strictly higher than +the ambient level to the set of candidates. + +Note [quantifyTyVars determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The results of quantifyTyVars are wrapped in a forall and can end up in the +interface file. One such example is inferred type signatures. They also affect +the results of optimizations, for example worker-wrapper. This means that to +get deterministic builds quantifyTyVars needs to be deterministic. + +To achieve this CandidatesQTvs is backed by deterministic sets which allows them +to be later converted to a list in a deterministic order. + +For more information about deterministic sets see +Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. +-} + +quantifyTyVars :: SkolemInfo + -> NonStandardDefaultingStrategy + -> CandidatesQTvs -- See Note [Dependent type variables] + -- Already zonked + -> TcM [TcTyVar] +-- See Note [quantifyTyVars] +-- Can be given a mixture of TcTyVars and TyVars, in the case of +-- associated type declarations. Also accepts covars, but *never* returns any. +-- According to Note [Use level numbers for quantification] and the +-- invariants on CandidateQTvs, we do not have to filter out variables +-- free in the environment here. Just quantify unconditionally, subject +-- to the restrictions in Note [quantifyTyVars]. +quantifyTyVars skol_info ns_strat dvs + -- short-circuit common case + | isEmptyCandidates dvs + = do { traceTc "quantifyTyVars has nothing to quantify" empty + ; return [] } + + | otherwise + = do { traceTc "quantifyTyVars {" + ( vcat [ text "ns_strat =" <+> ppr ns_strat + , text "dvs =" <+> ppr dvs ]) + + ; undefaulted <- defaultTyVars ns_strat dvs + ; final_qtvs <- liftZonkM $ mapMaybeM zonk_quant undefaulted + + ; traceTc "quantifyTyVars }" + (vcat [ text "undefaulted:" <+> pprTyVars undefaulted + , text "final_qtvs:" <+> pprTyVars final_qtvs ]) + + -- We should never quantify over coercion variables; check this + ; let co_vars = filter isCoVar final_qtvs + ; massertPpr (null co_vars) (ppr co_vars) + + ; return final_qtvs } + where + -- zonk_quant returns a tyvar if it should be quantified over; + -- otherwise, it returns Nothing. The latter case happens for + -- non-meta-tyvars + zonk_quant tkv + | not (isTyVar tkv) + = return Nothing -- this can happen for a covar that's associated with + -- a coercion hole. Test case: typecheck/should_compile/T2494 + + | otherwise + = Just <$> skolemiseQuantifiedTyVar skol_info tkv + +isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification + -> TcTyVar + -> Bool +isQuantifiableTv outer_tclvl tcv + | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately + = tcTyVarLevel tcv > outer_tclvl + | otherwise + = False + +zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> ZonkM TcTyCoVar +-- A tyvar binder is never a unification variable (TauTv), +-- rather it is always a skolem. It *might* be a TyVarTv. +-- (Because non-CUSK type declarations use TyVarTvs.) +-- Regardless, it may have a kind that has not yet been zonked, +-- and may include kind unification variables. +zonkAndSkolemise skol_info tyvar + | isTyVarTyVar tyvar + -- We want to preserve the binding location of the original TyVarTv. + -- This is important for error messages. If we don't do this, then + -- we get bad locations in, e.g., typecheck/should_fail/T2688 + = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar + ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } + + | otherwise + = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ + zonkTyCoVarKind tyvar + +skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> ZonkM TcTyVar +-- The quantified type variables often include meta type variables +-- we want to freeze them into ordinary type variables +-- The meta tyvar is updated to point to the new skolem TyVar. Now any +-- bound occurrences of the original type variable will get zonked to +-- the immutable version. +-- +-- We leave skolem TyVars alone; they are immutable. +-- +-- This function is called on both kind and type variables, +-- but kind variables *only* if PolyKinds is on. + +skolemiseQuantifiedTyVar skol_info tv + = case tcTyVarDetails tv of + MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv + + SkolemTv _ lvl _ -- It might be a skolem type variable, + -- for example from a user type signature + -- But it might also be a shared meta-variable across several + -- type declarations, each with its own skol_info. The first + -- will skolemise it, but the other uses must update its + -- skolem info (#22379) + -> do { kind <- zonkTcType (tyVarKind tv) + ; let details = SkolemTv skol_info lvl False + name = tyVarName tv + ; return (mkTcTyVar name kind details) } + + _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk + +-- | Default a type variable using the given defaulting strategy. +-- +-- See Note [Type variable defaulting options] in GHC.Types.Basic. +defaultTyVar :: DefaultingStrategy + -> TcTyVar -- If it's a MetaTyVar then it is unbound + -> TcM Bool -- True <=> defaulted away altogether +defaultTyVar def_strat tv + | not (isMetaTyVar tv) + || isTyVarTyVar tv + -- Do not default TyVarTvs. Doing so would violate the invariants + -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType. + -- #13343 is an example; #14555 is another + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return False + + | isRuntimeRepVar tv + , default_ns_vars + = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv liftedRepTy + ; return True } + + | isLevityVar tv + , default_ns_vars + = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv liftedDataConTy + ; return True } + + | isMultiplicityVar tv + , default_ns_vars + = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv manyDataConTy + ; return True } + + | isConcreteTyVar tv + -- We don't want to quantify; but neither can we default to + -- anything sensible. (If it has kind RuntimeRep or Levity, as is + -- often the case, it'll have been caught earlier by earlier + -- cases. So in this exotic situation we just promote. Not very + -- satisfing, but it's very much a corner case: #23051 + -- We should really implement the plan in #20686. + = do { lvl <- getTcLevel + ; _ <- promoteMetaTyVarTo lvl tv + ; return True } + + | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it + = default_kind_var tv + + | otherwise + = return False + + where + default_ns_vars :: Bool + default_ns_vars = defaultNonStandardTyVars def_strat + default_kind_var :: TyVar -> TcM Bool + -- defaultKindVar is used exclusively with -XNoPolyKinds + -- See Note [Defaulting with -XNoPolyKinds] + -- It takes an (unconstrained) meta tyvar and defaults it. + -- Works only on vars of type *; for other kinds, it issues an error. + default_kind_var kv + | isLiftedTypeKind (tyVarKind kv) + = do { traceTc "Defaulting a kind var to *" (ppr kv) + ; liftZonkM $ writeMetaTyVar kv liftedTypeKind + ; return True } + | otherwise + = do { addErr $ TcRnCannotDefaultKindVar kv' (tyVarKind kv') + -- We failed to default it, so return False to say so. + -- Hence, it'll get skolemised. That might seem odd, but we must either + -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType + -- Note [Recipe for checking a signature] + -- Otherwise we get level-number assertion failures. It doesn't matter much + -- because we are in an error situation anyway. + ; return False + } + where + (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv + +-- | Default some unconstrained type variables, as specified +-- by the defaulting options: +-- +-- - 'RuntimeRep' tyvars default to 'LiftedRep' +-- - 'Levity' tyvars default to 'Lifted' +-- - 'Multiplicity' tyvars default to 'Many' +-- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds +-- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) +defaultTyVars :: NonStandardDefaultingStrategy + -> CandidatesQTvs -- ^ all candidates for quantification + -> TcM [TcTyVar] -- ^ those variables not defaulted +defaultTyVars ns_strat dvs + = do { poly_kinds <- xoptM LangExt.PolyKinds + ; let + def_tvs, def_kvs :: DefaultingStrategy + def_tvs = NonStandardDefaulting ns_strat + def_kvs | poly_kinds = def_tvs + | otherwise = DefaultKindVars + -- As -XNoPolyKinds precludes polymorphic kind variables, we default them. + -- For example: + -- + -- type F :: Type -> Type + -- type family F a where + -- F (a -> b) = b + -- + -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled + -- we must default the kind variable `r :: RuntimeRep`. + -- Test case: T20584. + ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs + ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs + ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] + undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] + ; return (undefaulted_kvs ++ undefaulted_tvs) } + -- NB: kvs before tvs because tvs may depend on kvs + where + (dep_kvs, nondep_tvs) = candidateVars dvs + +skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> ZonkM TyVar +-- We have a Meta tyvar with a ref-cell inside it +-- Skolemise it, so that we are totally out of Meta-tyvar-land +-- We create a skolem TcTyVar, not a regular TyVar +-- See Note [Zonking to Skolem] +-- +-- Its level should be one greater than the ambient level, which will typically +-- be the same as the level on the meta-tyvar. But not invariably; for example +-- f :: (forall a b. SameKind a b) -> Int +-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each +-- have a level-2 kind unification variable, since it might get unified with another +-- of the level-2 skolems e.g. 'k' in this version +-- f :: (forall k (a :: k) b. SameKind a b) -> Int +-- So when we quantify the kind vars at the top level of the signature, the ambient +-- level is 1, but we will quantify over kappa[2]. + +skolemiseUnboundMetaTyVar skol_info tv + = assertPpr (isMetaTyVar tv) (ppr tv) $ + do { check_empty tv + -- Get the location and level from "here", + -- i.e. where we are generalising + ; ZonkGblEnv { zge_src_span = here, zge_tc_level = tc_lvl } + <- getZonkGblEnv + ; kind <- zonkTcType (tyVarKind tv) + ; let tv_name = tyVarName tv + -- See Note [Skolemising and identity] + final_name | isSystemName tv_name + = mkInternalName (nameUnique tv_name) + (nameOccName tv_name) here + | otherwise + = tv_name + details = SkolemTv skol_info (pushTcLevel tc_lvl) False + final_tv = mkTcTyVar final_name kind details + + ; traceZonk "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } + where + check_empty tv -- [Sept 04] Check for non-empty. + = when debugIsOn $ -- See Note [Silly Type Synonyms] + do { cts <- readMetaTyVar tv + ; case cts of + Flexi -> return () + Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $ + return () } + +{- Note [Error on unconstrained meta-variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + +* type C :: Type -> Type -> Constraint + class (forall a. a b ~ a c) => C b c + +* type T = forall a. Proxy a + +* data (forall a. a b ~ a c) => T b c + +* type instance F Int = Proxy Any + where Any :: forall k. k + +In the first three cases we will infer a :: Type -> kappa, but then +we get no further information on kappa. In the last, we will get + Proxy kappa Any +but again will get no further info on kappa. + +What do do? + A. We could choose kappa := Type. But this only works when the kind of kappa + is Type (true in this example, but not always). + B. We could default to Any. + C. We could quantify. + D. We could error. + +We choose (D), as described in #17567, and implement this choice in +doNotQuantifyTyVars. Discussion of alternatives A-C is below. + +NB: this is all rather similar to, but sadly not the same as + Note [Naughty quantification candidates] + +To do this, we must take an extra step before doing the final zonk to create +e.g. a TyCon. (There is no problem in the final term-level zonk. See the +section on alternative (B) below.) This extra step is needed only for +constructs that do not quantify their free meta-variables, such as a class +constraint or right-hand side of a type synonym. + +Specifically: before the final zonk, every construct must either call +quantifyTyVars or doNotQuantifyTyVars. The latter issues an error +if it is passed any free variables. (Exception: we still default +RuntimeRep and Multiplicity variables.) + +Because no meta-variables remain after quantifying or erroring, we perform +the zonk with NoFlexi, which panics upon seeing a meta-variable. + +Alternatives A-C, not implemented: + +A. As stated above, this works only sometimes. We might have a free + meta-variable of kind Nat, for example. + +B. This is what we used to do, but it caused Any to appear in error + messages sometimes. See #17567 for several examples. Defaulting to + Any during the final, whole-program zonk is OK, though, because + we are completely done type-checking at that point. No chance to + leak into an error message. + +C. Examine the class declaration at the top of this Note again. + Where should we quantify? We might imagine quantifying and + putting the kind variable in the forall of the quantified constraint. + But what if there are nested foralls? Which one should get the + variable? Other constructs have other problems. (For example, + the right-hand side of a type family instance equation may not + be a poly-type.) + + More broadly, the GHC AST defines a set of places where it performs + implicit lexical generalization. For example, in a type + signature + + f :: Proxy a -> Bool + + the otherwise-unbound a is lexically quantified, giving us + + f :: forall a. Proxy a -> Bool + + The places that allow lexical quantification are marked in the AST with + HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound + variables. + + Later, during type-checking, we discover that a's kind is unconstrained. + We thus quantify *again*, to + + f :: forall {k} (a :: k). Proxy @k a -> Bool + + It is this second quantification that this Note is really about -- + let's call it *inferred quantification*. + So there are two sorts of implicit quantification in types: + 1. Lexical quantification: signalled by HsImplicitBndrs, occurs over + variables mentioned by the user but with no explicit binding site, + suppressed by a user-written forall (by the forall-or-nothing rule, + in Note [forall-or-nothing rule] in GHC.Hs.Type). + 2. Inferred quantification: no signal in HsSyn, occurs over unconstrained + variables invented by the type-checker, possible only with -XPolyKinds, + unaffected by forall-or-nothing rule + These two quantifications are performed in different compiler phases, and are + essentially unrelated. However, it is convenient + for programmers to remember only one set of implicit quantification + sites. So, we choose to use the same places (those with HsImplicitBndrs) + for lexical quantification as for inferred quantification of unconstrained + meta-variables. Accordingly, there is no quantification in a class + constraint, or the other constructs that call doNotQuantifyTyVars. +-} + +doNotQuantifyTyVars :: CandidatesQTvs + -> (TidyEnv -> ZonkM (TidyEnv, UninferrableTyVarCtx)) + -- ^ like "the class context (D a b, E foogle)" + -> TcM () +-- See Note [Error on unconstrained meta-variables] +doNotQuantifyTyVars dvs where_found + | isEmptyCandidates dvs + = traceTc "doNotQuantifyTyVars has nothing to error on" empty + + | otherwise + = do { traceTc "doNotQuantifyTyVars" (ppr dvs) + ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs + -- could have regular TyVars here, in an associated type RHS, or + -- bound by a type declaration head. So filter looking only for + -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` + -- are OK + ; let leftover_metas = filter isMetaTyVar undefaulted + ; unless (null leftover_metas) $ + do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas + ; (tidy_env2, where_doc) <- liftZonkM $ where_found tidy_env1 + ; let msg = TcRnUninferrableTyVar tidied_tvs where_doc + ; failWithTcM (tidy_env2, msg) } + ; traceTc "doNotQuantifyTyVars success" empty } + +{- Note [Defaulting with -XNoPolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Compose f g a = Mk (f (g a)) + +We infer + + Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * + Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). + f (g a) -> Compose k1 k2 f g a + +Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. +What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, +we just defaulted all kind variables to *. But that's no good here, +because the kind variables in 'Mk aren't of kind *, so defaulting to * +is ill-kinded. + +After some debate on #11334, we decided to issue an error in this case. +The code is in defaultKindVar. + +Note [What is a meta variable?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "meta type-variable", also know as a "unification variable" is a placeholder +introduced by the typechecker for an as-yet-unknown monotype. + +For example, when we see a call `reverse (f xs)`, we know that we calling + reverse :: forall a. [a] -> [a] +So we know that the argument `f xs` must be a "list of something". But what is +the "something"? We don't know until we explore the `f xs` a bit more. So we set +out what we do know at the call of `reverse` by instantiating its type with a fresh +meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the +result, is `[alpha]`. The unification variable `alpha` stands for the +as-yet-unknown type of the elements of the list. + +As type inference progresses we may learn more about `alpha`. For example, suppose +`f` has the type + f :: forall b. b -> [Maybe b] +Then we instantiate `f`'s type with another fresh unification variable, say +`beta`; and equate `f`'s result type with reverse's argument type, thus +`[alpha] ~ [Maybe beta]`. + +Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've +refined our knowledge about `alpha`. And so on. + +If you found this Note useful, you may also want to have a look at +Section 5 of "Practical type inference for higher rank types" (Peyton Jones, +Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). + +Note [Zonking to Skolem] +~~~~~~~~~~~~~~~~~~~~~~~~ +We used to zonk quantified type variables to regular TyVars. However, this +leads to problems. Consider this program from the regression test suite: + + eval :: Int -> String -> String -> String + eval 0 root actual = evalRHS 0 root actual + + evalRHS :: Int -> a + evalRHS 0 root actual = eval 0 root actual + +It leads to the deferral of an equality (wrapped in an implication constraint) + + forall a. () => ((String -> String -> String) ~ a) + +which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck). +In the meantime `a' is zonked and quantified to form `evalRHS's signature. +This has the *side effect* of also zonking the `a' in the deferred equality +(which at this point is being handed around wrapped in an implication +constraint). + +Finally, the equality (with the zonked `a') will be handed back to the +simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop. +If we zonk `a' with a regular type variable, we will have this regular type +variable now floating around in the simplifier, which in many places assumes to +only see proper TcTyVars. + +We can avoid this problem by zonking with a skolem TcTyVar. The +skolem is rigid (which we require for a quantified variable), but is +still a TcTyVar that the simplifier knows how to deal with. + +Note [Skolemising and identity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some places, we make a TyVarTv for a binder. E.g. + class C a where ... +As Note [Inferring kinds for type declarations] discusses, +we make a TyVarTv for 'a'. Later we skolemise it, and we'd +like to retain its identity, location info etc. (If we don't +retain its identity we'll have to do some pointless swizzling; +see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity +but not its location we'll lose the detailed binding site info. + +Conclusion: use the Name of the TyVarTv. But we don't want +to do that when skolemising random unification variables; +there the location we want is the skolemisation site. + +Fortunately we can tell the difference: random unification +variables have System Names. That's why final_name is +set based on the isSystemName test. + + +Note [Silly Type Synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + type C u a = u -- Note 'a' unused + + foo :: (forall a. C u a -> C u a) -> u + foo x = ... + + bar :: Num u => u + bar = foo (\t -> t + t) + +* From the (\t -> t+t) we get type {Num d} => d -> d + where d is fresh. + +* Now unify with type of foo's arg, and we get: + {Num (C d a)} => C d a -> C d a + where a is fresh. + +* Now abstract over the 'a', but float out the Num (C d a) constraint + because it does not 'really' mention a. (see exactTyVarsOfType) + The arg to foo becomes + \/\a -> \t -> t+t + +* So we get a dict binding for Num (C d a), which is zonked to give + a = () + Note (Sept 04): now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] + +* Then the \/\a abstraction has a zonked 'a' in it. + +All very silly. I think its harmless to ignore the problem. We'll end up with +a \/\a in the final result but all the occurrences of a will be zonked to () +-} + +-------------------------------------------------------------------------------- + +-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the +-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the +-- usage environment. See also Note [Wrapper returned from tcSubMult] in +-- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function. +tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper) +tcCheckUsage name id_mult thing_inside + = do { (local_usage, result) <- tcCollectingUsage thing_inside + ; wrapper <- check_then_add_usage local_usage + ; return (result, wrapper) } + where + check_then_add_usage :: UsageEnv -> TcM HsWrapper + -- Checks that the usage of the newly introduced binder is compatible with + -- its multiplicity, and combines the usage of non-new binders to |uenv| + check_then_add_usage uenv + = do { let actual_u = lookupUE uenv name + ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) + ; wrapper <- case actual_u of + Bottom -> return idHsWrapper + Zero -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult + MUsage m -> do { m <- promote_mult m + ; tcSubMult (UsageEnvironmentOf name) m id_mult } + ; tcEmitBindingUsage (deleteUE uenv name) + ; return wrapper } + + -- This is gross. The problem is in test case typecheck/should_compile/T18998: + -- f :: a %1-> Id n a -> Id n a + -- f x (MkId _) = MkId x + -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors + -- invents a new multiplicity variable p[2] for the application MkId x. This + -- variable is at level 2, bumped because of the GADT pattern-match (MkId _). + -- We eventually unify the variable with One, due to the call to tcSubMult in + -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check + -- fails. + -- + -- What to do? If we did inference "for real", the sub-multiplicity constraint + -- would end up in the implication of the GADT pattern-match, and all would + -- be well. But we don't have a real sub-multiplicity constraint to put in + -- the implication. (Multiplicity inference works outside the usual generate- + -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we + -- must promote all multiplicity variables to reflect this outer TcLevel. + -- It's reminiscent of floating a constraint, really, so promotion is + -- appropriate. The promoteTcType function works only on types of kind TYPE rr, + -- so we can't use it here. Thus, this dirtiness. + -- + -- It works nicely in practice. + -- + -- We use a set to avoid calling promoteMetaTyVarTo twice on the same + -- metavariable. This happened in #19400. + promote_mult m = do { fvs <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfType m) + ; any_promoted <- promoteTyVarSet fvs + ; if any_promoted then liftZonkM $ zonkTcType m else return m + } + +{- ********************************************************************* +* * + Short-cuts for overloaded numeric literals +* * +********************************************************************* -} + +-- Overloaded literals. Here mainly because it uses isIntTy etc + +{- Note [Short cut for overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). +But if we have a list like + [4,2,3,2,4,4,2]::[Int] +we use a lot of compile time and space generating and solving all those Num +constraints, and generating calls to fromInteger etc. Better just to cut to +the chase, and cough up an Int literal. Large collections of literals like this +sometimes appear in source files, so it's quite a worthwhile fix. + +So we try to take advantage of whatever nearby type information we have, +to short-cut the process for built-in types. We can do this in two places; + +* In the typechecker, when we are about to typecheck the literal. +* If that fails, in the desugarer, once we know the final type. +-} + +tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) +tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty + | not rebindable + , Just res_ty <- checkingExpType_maybe exp_res_ty + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + Just expr -> return $ Just $ + lit { ol_ext = OverLitTc False expr res_ty } + Nothing -> return Nothing } + | otherwise + = return Nothing + +shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) +shortCutLit platform val res_ty + = case val of + HsIntegral int_lit -> go_integral int_lit + HsFractional frac_lit -> go_fractional frac_lit + HsIsString s src -> go_string s src + where + go_integral int@(IL src neg i) + | isIntTy res_ty && platformInIntRange platform i + = Just (HsLit noAnn (HsInt noExtField int)) + | isWordTy res_ty && platformInWordRange platform i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy res_ty + = Just (HsLit noAnn (HsInteger src i res_ty)) + | otherwise + = go_fractional (integralFractionalLit neg i) + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + + go_fractional f + | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing + where + valueInRange = + case f of + FL { fl_exp = e } -> (-100) <= e && e <= 100 + -- We limit short-cutting Fractional Literals to when their power of 10 + -- is less than 100, which ensures desugaring isn't slow. + + go_string src s + | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc +mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName + + +{- ********************************************************************* +* * + Promotion +* * +********************************************************************* -} + +promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool +-- When we float a constraint out of an implication we must restore +-- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType +-- Return True <=> we did some promotion +-- Also returns either the original tyvar (no promotion) or the new one +-- See Note [Promoting unification variables] +promoteMetaTyVarTo tclvl tv + | assertPpr (isMetaTyVar tv) (ppr tv) $ + tcTyVarLevel tv `strictlyDeeperThan` tclvl + = do { cloned_tv <- cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; liftZonkM $ writeMetaTyVar tv (mkTyVarTy rhs_tv) + ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv) + ; return True } + | otherwise + = return False + +-- Returns whether or not *any* tyvar is defaulted +promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool +promoteTyVarSet tvs + = do { tclvl <- getTcLevel + ; bools <- mapM (promoteMetaTyVarTo tclvl) $ + filter isPromotableMetaTyVar $ + nonDetEltsUniqSet tvs + -- Non-determinism is OK because order of promotion doesn't matter + ; return (or bools) } + +{- +%************************************************************************ +%* * + Representation polymorphism checks +* * +***********************************************************************-} + +-- | Check that the specified type has a fixed runtime representation. +-- +-- If it isn't, throw a representation-polymorphism error appropriate +-- for the context (as specified by the 'FixedRuntimeRepProvenance'). +-- +-- Unlike the other representation polymorphism checks, which can emit +-- new Wanted constraints to be solved by the constraint solver, this function +-- does not emit any constraints: it has enough information to immediately +-- make a decision. +-- +-- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM () +checkTypeHasFixedRuntimeRep prov ty = + unless (typeHasFixedRuntimeRep ty) + (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) + +{- +%************************************************************************ +%* * + Error messages +* * +************************************************************************* + +-} + +-- See Note [Naughty quantification candidates] +naughtyQuantification :: TcType -- original type user wanted to quantify + -> TcTyVar -- naughty var + -> TyVarSet -- skolems that would escape + -> TcM a +naughtyQuantification orig_ty tv escapees + = do { (orig_ty1, escapees') <- liftZonkM $ + do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked + ; escapees' <- zonkTcTyVarsToTcTyVars $ + nonDetEltsUniqSet escapees + -- we'll just be printing, so no harmful non-determinism + ; return (orig_ty1, escapees') } + + ; let fvs = tyCoVarsOfTypeWellScoped orig_ty1 + env0 = tidyFreeTyCoVars emptyTidyEnv fvs + env = env0 `delTidyEnvList` escapees' + -- this avoids gratuitous renaming of the escaped + -- variables; very confusing to users! + + orig_ty' = tidyType env orig_ty1 + tidied = map (tidyTyCoVarOcc env) escapees' + msg = TcRnSkolemEscape tidied (tidyTyCoVarOcc env tv) orig_ty' + + ; failWithTcM (env, msg) } 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 @@ -1,2722 +1,3276 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecursiveDo #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - --- | Type subsumption and unification -module GHC.Tc.Utils.Unify ( - -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcWrapResultMono, - tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType, - tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, - tcSubTypeAmbiguity, tcSubMult, - checkConstraints, checkTvConstraints, - buildImplicationFor, buildTvImplication, emitResidualTvConstraint, - - -- Various unifications - unifyType, unifyKind, unifyExpectedType, - uType, promoteTcType, - swapOverTyVars, startSolvingByUnification, - - -------------------------------- - -- Holes - tcInfer, - matchExpectedListTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchExpectedFunKind, - matchActualFunTySigma, matchActualFunTysRho, - - checkTyVarEq, checkTyFamEq, checkTypeEq - - ) where - -import GHC.Prelude - -import GHC.Hs - -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, hasFixedRuntimeRep_syntactic ) -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Instantiate -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.TcType - -import GHC.Core.Type -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr( debugPprType ) -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Multiplicity - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Types.Name( Name, isSystemName ) - -import GHC.Builtin.Types -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Types.Basic -import GHC.Data.Bag -import GHC.Data.FastString( fsLit ) -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import GHC.Exts ( inline ) -import Control.Monad -import qualified Data.Semigroup as S ( (<>) ) - -{- ********************************************************************* -* * - matchActualFunTys -* * -********************************************************************* -} - --- | 'matchActualFunTySigma' looks for just one function arrow, --- returning an uninstantiated sigma-type. --- --- Invariant: the returned argument type has a syntactically fixed --- RuntimeRep in the sense of Note [Fixed RuntimeRep] --- in GHC.Tc.Utils.Concrete. --- --- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTySigma - :: ExpectedFunTyOrigin - -- ^ See Note [Herald for matchExpectedFunTys] - -> Maybe TypedThing - -- ^ The thing with type TcSigmaType - -> (Arity, [Scaled TcSigmaType]) - -- ^ Total number of value args in the call, and - -- types of values args to which function has - -- been applied already (reversed) - -- (Both are used only for error messages) - -> TcRhoType - -- ^ Type to analyse: a TcRhoType - -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) --- This function takes in a type to analyse (a RhoType) and returns --- an argument type and a result type (splitting apart a function arrow). --- The returned argument type is a SigmaType with a fixed RuntimeRep; --- as explained in Note [Return arguments with a fixed RuntimeRep]. --- --- See Note [matchActualFunTy error handling] for the first three arguments - --- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty --- then wrap :: fun_ty ~> (arg_ty -> res_ty) --- and NB: res_ty is an (uninstantiated) SigmaType - -matchActualFunTySigma herald mb_thing err_info fun_ty - = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $ - go fun_ty - where - -- Does not allocate unnecessary meta variables: if the input already is - -- a function, we just take it apart. Not only is this efficient, - -- it's important for higher rank: the argument might be of form - -- (forall a. ty) -> other - -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd - -- hide the forall inside a meta-variable - go :: TcRhoType -- The type we're processing, perhaps after - -- expanding type synonyms - -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) - go ty | Just ty' <- coreView ty = go ty' - - go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) - = assert (isVisibleFunArg af) $ - do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty - ; return (idHsWrapper, Scaled w arg_ty, res_ty) } - - go ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go ty' - Flexi -> defer ty } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go ty = addErrCtxtM (mk_ctxt ty) (defer ty) - - ------------ - defer fun_ty - = do { arg_ty <- newOpenFlexiTyVarTy - ; res_ty <- newOpenFlexiTyVarTy - ; mult <- newFlexiTyVarTy multiplicityTy - ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty - ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty - ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } - - ------------ - mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, SDoc) - mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far) - res_ty n_val_args_in_call - (n_val_args_in_call, arg_tys_so_far) = err_info - -{- Note [matchActualFunTy error handling] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchActualFunTySigma is made much more complicated by the -desire to produce good error messages. Consider the application - f @Int x y -In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments, -and then call matchActualFunTysPart for each individual value -argument. It, in turn, must instantiate any type/dictionary args, -before looking for an arrow type. - -But if it doesn't find an arrow type, it wants to generate a message -like "f is applied to two arguments but its type only has one". -To do that, it needs to know about the args that tcArgs has already -munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; -and hence also the accumulating so_far arg to 'go'. - -This allows us (in mk_ctxt) to construct f's /instantiated/ type, -with just the values-arg arrows, which is what we really want -in the error message. - -Ugh! --} - --- | Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application. --- --- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep --- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. --- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe TypedThing -- ^ the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) --- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) --- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) --- and res_ty is a RhoType --- NB: the returned type is top-instantiated; it's a RhoType -matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty - = go n_val_args_wanted [] fun_ty - where - go n so_far fun_ty - | not (isRhoTy fun_ty) - = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty - ; (wrap2, arg_tys, res_ty) <- go n so_far rho - ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - - go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) - - go n so_far fun_ty - = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma - herald mb_thing - (n_val_args_wanted, so_far) - fun_ty - ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 - ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty - -- NB: arg_ty1 comes from matchActualFunTySigma, so it has - -- a syntactically fixed RuntimeRep as needed to call mkWpFun. - ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } - -{- -************************************************************************ -* * - matchExpected functions -* * -************************************************************************ - -Note [Herald for matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'herald' always looks like: - "The equation(s) for 'f' have" - "The abstraction (\x.e) takes" - "The section (+ x) expects" - "The function 'f' is applied to" - -This is used to construct a message of form - - The abstraction `\Just 1 -> ...' takes two arguments - but its type `Maybe a -> a' has only one - - The equation(s) for `f' have two arguments - but its type `Maybe a -> a' has only one - - The section `(f 3)' requires 'f' to take two arguments - but its type `Int -> Int' has only one - - The function 'f' is applied to two arguments - but its type `Int -> Int' has only one - -When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the -picture, we have a choice in deciding whether to count the type applications as -proper arguments: - - The function 'f' is applied to one visible type argument - and two value arguments - but its type `forall a. a -> a` has only one visible type argument - and one value argument - -Or whether to include the type applications as part of the herald itself: - - The expression 'f @Int' is applied to two arguments - but its type `Int -> Int` has only one - -The latter is easier to implement and is arguably easier to understand, so we -choose to implement that option. - -Note [matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchExpectedFunTys checks that a sigma has the form -of an n-ary function. It passes the decomposed type to the -thing_inside, and returns a wrapper to coerce between the two types - -It's used wherever a language construct must have a functional type, -namely: - A lambda expression - A function definition - An operator section - -This function must be written CPS'd because it needs to fill in the -ExpTypes produced for arguments before it can fill in the ExpType -passed in. - -Note [Return arguments with a fixed RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The functions - - - matchExpectedFunTys, - - matchActualFunTySigma, - - matchActualFunTysRho, - -peel off argument types, as explained in Note [matchExpectedFunTys]. -It's important that these functions return argument types that have -a fixed runtime representation, otherwise we would be in violation -of the representation-polymorphism invariants of -Note [Representation polymorphism invariants] in GHC.Core. - -This is why all these functions have an additional invariant, -that the argument types they return all have a syntactically fixed RuntimeRep, -in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. - -Example: - - Suppose we have - - type F :: Type -> RuntimeRep - type family F a where { F Int = LiftedRep } - - type Dual :: Type -> Type - type family Dual a where - Dual a = a -> () - - f :: forall (a :: TYPE (F Int)). Dual a - f = \ x -> () - - The body of `f` is a lambda abstraction, so we must be able to split off - one argument type from its type. This is handled by `matchExpectedFunTys` - (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that - looks like this: - - f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) - f = \ @(a :: TYPE (F Int)) -> - (\ (x :: (a |> (TYPE F[0]))) -> ()) - `cast` - (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>))) - - Two important transformations took place: - - 1. We inserted casts around the argument type to ensure that it has - a fixed runtime representation, as required by invariant (I1) from - Note [Representation polymorphism invariants] in GHC.Core. - 2. We inserted a cast around the whole lambda to make everything line up - with the type signature. --} - --- | Use this function to split off arguments types when you have an --- \"expected\" type. --- --- This function skolemises at each polytype. --- --- Invariant: this function only applies the provided function --- to a list of argument types which all have a syntactically fixed RuntimeRep --- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. --- See Note [Return arguments with a fixed RuntimeRep]. -matchExpectedFunTys :: forall a. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] - -> UserTypeCtxt - -> Arity - -> ExpRhoType -- Skolemised - -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a) - -> TcM (HsWrapper, a) --- If matchExpectedFunTys n ty = (wrap, _) --- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald ctx arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty - where - -- Skolemise any foralls /before/ the zero-arg case - -- so that we guarantee to return a rho-type - go acc_arg_tys n ty - | (tvs, theta, _) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> - go acc_arg_tys n ty' - ; return (wrap_gen <.> wrap_res, result) } - - -- No more args; do this /before/ coreView, so - -- that we do not unnecessarily unwrap synonyms - go acc_arg_tys 0 rho_ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty) - ; return (idHsWrapper, result) } - - go acc_arg_tys n ty - | Just ty' <- coreView ty = go acc_arg_tys n ty' - - go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) - = assert (isVisibleFunArg af) $ - do { let arg_pos = 1 + length acc_arg_tys -- for error messages only - ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty - ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) - (n-1) res_ty - ; let wrap_arg = mkWpCastN arg_co - fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty - ; return (fun_wrap, result) } - - go acc_arg_tys n ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go acc_arg_tys n ty' - Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $ - defer acc_arg_tys n (mkCheckExpType ty) - - ------------ - defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) - defer acc_arg_tys n fun_ty - = do { let last_acc_arg_pos = length acc_arg_tys - ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n] - ; res_ty <- newInferExpType - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty - ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty - ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (wrap, result) } - - new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR) - new_exp_arg_ty arg_pos -- position for error messages only - = mkScaled <$> newFlexiTyVarTy multiplicityTy - <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) - - ------------ - mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) - mk_ctxt arg_tys res_ty env - = mkFunTysMsg env herald arg_tys' res_ty arity - where - arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $ - reverse arg_tys - -- this is safe b/c we're called from "go" - -mkFunTysMsg :: TidyEnv - -> ExpectedFunTyOrigin - -> [Scaled TcType] -> TcType -> Arity - -> TcM (TidyEnv, SDoc) -mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call - = do { (env', fun_rho) <- zonkTidyTcType env $ - mkScaledFunTys arg_tys res_ty - - ; let (all_arg_tys, _) = splitFunTys fun_rho - n_fun_args = length all_arg_tys - - msg | n_val_args_in_call <= n_fun_args -- Enough args, in the end - = text "In the result of a function call" - | otherwise - = hang (full_herald <> comma) - 2 (sep [ text "but its type" <+> quotes (pprType fun_rho) - , if n_fun_args == 0 then text "has none" - else text "has only" <+> speakN n_fun_args]) - - ; return (env', msg) } - where - full_herald = pprExpectedFunTyHerald herald - <+> speakNOf n_val_args_in_call (text "value argument") - ----------------------- -matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) --- Special case for lists -matchExpectedListTy exp_ty - = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty - ; return (co, elt_ty) } - ---------------------- -matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * - -> TcRhoType -- orig_ty - -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty - [TcSigmaType]) -- Element types, k1 k2 k3 a b c - --- It's used for wired-in tycons, so we call checkWiredInTyCon --- Precondition: never called with FunTyCon --- Precondition: input type :: * --- Postcondition: (T k1 k2 k3 a b c) is well-kinded - -matchExpectedTyConApp tc orig_ty - = assertPpr (isAlgTyCon tc) (ppr tc) $ - go orig_ty - where - go ty - | Just ty' <- coreView ty - = go ty' - - go ty@(TyConApp tycon args) - | tc == tycon -- Common case - = return (mkNomReflCo ty, args) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- If the common case does not occur, instantiate a template - -- T k1 .. kn t1 .. tm, and unify with the original type - -- Doing it this way ensures that the types we return are - -- kind-compatible with T. For example, suppose we have - -- matchExpectedTyConApp T (f Maybe) - -- where data T a = MkT a - -- Then we don't want to instantiate T's data constructors with - -- (a::*) ~ Maybe - -- because that'll make types that are utterly ill-kinded. - -- This happened in #7368 - defer - = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) - ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) - ; let args = mkTyVarTys arg_tvs - tc_template = mkTyConApp tc args - ; co <- unifyType Nothing tc_template orig_ty - ; return (co, args) } - ----------------------- -matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (TcCoercion, -- m a ~N orig_ty - (TcSigmaType, TcSigmaType)) -- Returns m, a --- If the incoming type is a mutable type variable of kind k, then --- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. - -matchExpectedAppTy orig_ty - = go orig_ty - where - go ty - | Just ty' <- coreView ty = go ty' - - | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- Defer splitting by generating an equality constraint - defer - = do { ty1 <- newFlexiTyVarTy kind1 - ; ty2 <- newFlexiTyVarTy kind2 - ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty - ; return (co, (ty1, ty2)) } - - orig_kind = typeKind orig_ty - kind1 = mkVisFunTyMany liftedTypeKind orig_kind - kind2 = liftedTypeKind -- m :: * -> k - -- arg type :: * - -{- ********************************************************************** -* - fillInferResult -* -********************************************************************** -} - -{- Note [inferResultToType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -expTypeToType and inferResultType convert an InferResult to a monotype. -It must be a monotype because if the InferResult isn't already filled in, -we fill it in with a unification variable (hence monotype). So to preserve -order-independence we check for mono-type-ness even if it *is* filled in -already. - -See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and -Note [fillInferResult]. --} - --- | Fill an 'InferResult' with the given type. --- --- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@, --- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@. --- --- This function enforces the following invariants: --- --- - Level invariant. --- The stored type @t2@ is at the same level as given by the --- 'ir_lvl' field. --- - FRR invariant. --- Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed --- to have a syntactically fixed RuntimeRep, in the sense of --- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -fillInferResult :: TcType -> InferResult -> TcM TcCoercionN -fillInferResult act_res_ty (IR { ir_uniq = u - , ir_lvl = res_lvl - , ir_frr = mb_frr - , ir_ref = ref }) - = do { mb_exp_res_ty <- readTcRef ref - ; case mb_exp_res_ty of - Just exp_res_ty - -- We progressively refine the type stored in 'ref', - -- for example when inferring types across multiple equations. - -- - -- Example: - -- - -- \ x -> case y of { True -> x ; False -> 3 :: Int } - -- - -- When inferring the return type of this function, we will create - -- an 'Infer' 'ExpType', which will first be filled by the type of 'x' - -- after typechecking the first equation, and then filled again with - -- the type 'Int', at which point we want to ensure that we unify - -- the type of 'x' with 'Int'. This is what is happening below when - -- we are "joining" several inferred 'ExpType's. - -> do { traceTc "Joining inferred ExpType" $ - ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty - ; cur_lvl <- getTcLevel - ; unless (cur_lvl `sameDepthAs` res_lvl) $ - ensureMonoType act_res_ty - ; unifyType Nothing act_res_ty exp_res_ty } - Nothing - -> do { traceTc "Filling inferred ExpType" $ - ppr u <+> text ":=" <+> ppr act_res_ty - - -- Enforce the level invariant: ensure the TcLevel of - -- the type we are writing to 'ref' matches 'ir_lvl'. - ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty - - -- Enforce the FRR invariant: ensure the type has a syntactically - -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing'). - ; (frr_co, act_res_ty) <- - case mb_frr of - Nothing -> return (mkNomReflCo act_res_ty, act_res_ty) - Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty - - -- Compose the two coercions. - ; let final_co = prom_co `mkTransCo` frr_co - - ; writeTcRef ref (Just act_res_ty) - - ; return final_co } - } - -{- Note [fillInferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When inferring, we use fillInferResult to "fill in" the hole in InferResult - data InferResult = IR { ir_uniq :: Unique - , ir_lvl :: TcLevel - , ir_ref :: IORef (Maybe TcType) } - -There are two things to worry about: - -1. What if it is under a GADT or existential pattern match? - - GADTs: a unification variable (and Infer's hole is similar) is untouchable - - Existentials: be careful about skolem-escape - -2. What if it is filled in more than once? E.g. multiple branches of a case - case e of - T1 -> e1 - T2 -> e2 - -Our typing rules are: - -* The RHS of a existential or GADT alternative must always be a - monotype, regardless of the number of alternatives. - -* Multiple non-existential/GADT branches can have (the same) - higher rank type (#18412). E.g. this is OK: - case e of - True -> hr - False -> hr - where hr:: (forall a. a->a) -> Int - c.f. Section 7.1 of "Practical type inference for arbitrary-rank types" - We use choice (2) in that Section. - (GHC 8.10 and earlier used choice (1).) - - But note that - case e of - True -> hr - False -> \x -> hr x - will fail, because we still /infer/ both branches, so the \x will get - a (monotype) unification variable, which will fail to unify with - (forall a. a->a) - -For (1) we can detect the GADT/existential situation by seeing that -the current TcLevel is greater than that stored in ir_lvl of the Infer -ExpType. We bump the level whenever we go past a GADT/existential match. - -Then, before filling the hole use promoteTcType to promote the type -to the outer ir_lvl. promoteTcType does this - - create a fresh unification variable alpha at level ir_lvl - - emits an equality alpha[ir_lvl] ~ ty - - fills the hole with alpha -That forces the type to be a monotype (since unification variables can -only unify with monotypes); and catches skolem-escapes because the -alpha is untouchable until the equality floats out. - -For (2), we simply look to see if the hole is filled already. - - if not, we promote (as above) and fill the hole - - if it is filled, we simply unify with the type that is - already there - -There is one wrinkle. Suppose we have - case e of - T1 -> e1 :: (forall a. a->a) -> Int - G2 -> e2 -where T1 is not GADT or existential, but G2 is a GADT. Then suppose the -T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. -But now the G2 alternative must not *just* unify with that else we'd risk -allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first -we'd have filled the hole with a unification variable, which enforces a -monotype. - -So if we check G2 second, we still want to emit a constraint that restricts -the RHS to be a monotype. This is done by ensureMonoType, and it works -by simply generating a constraint (alpha ~ ty), where alpha is a fresh -unification variable. We discard the evidence. - --} - - - -{- -************************************************************************ -* * - Subsumption checking -* * -************************************************************************ - -Note [Subsumption checking: tcSubType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All the tcSubType calls have the form - tcSubType actual_ty expected_ty -which checks - actual_ty <= expected_ty - -That is, that a value of type actual_ty is acceptable in -a place expecting a value of type expected_ty. I.e. that - - actual ty is more polymorphic than expected_ty - -It returns a wrapper function - co_fn :: actual_ty ~ expected_ty -which takes an HsExpr of type actual_ty into one of type -expected_ty. - -Note [Ambiguity check and deep subsumption] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (forall b. Eq b => a -> a) -> Int - -Does `f` have an ambiguous type? The ambiguity check usually checks -that this definition of f' would typecheck, where f' has the exact same -type as f: - f' :: (forall b. Eq b => a -> a) -> Intp - f' = f - -This will be /rejected/ with DeepSubsumption but /accepted/ with -ShallowSubsumption. On the other hand, this eta-expanded version f'' -would be rejected both ways: - f'' :: (forall b. Eq b => a -> a) -> Intp - f'' x = f x - -This is squishy in the same way as other examples in GHC.Tc.Validity -Note [The squishiness of the ambiguity check] - -The situation in June 2022. Since we have SimpleSubsumption at the moment, -we don't want introduce new breakage if you add -XDeepSubsumption, by -rejecting types as ambiguous that weren't ambiguous before. So, as a -holding decision, we /always/ use SimpleSubsumption for the ambiguity check -(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. --} - - - ------------------ --- tcWrapResult needs both un-type-checked (for origins and error messages) --- and type-checked (for wrapping) expressions -tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTc) -tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr - -tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTc) -tcWrapResultO orig rn_expr expr actual_ty res_ty - = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty - , text "Expected:" <+> ppr res_ty ]) - ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty - ; return (mkHsWrap wrap expr) } - -tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc - -> TcRhoType -- Actual -- a rho-type not a sigma-type - -> ExpRhoType -- Expected - -> TcM (HsExpr GhcTc) --- A version of tcWrapResult to use when the actual type is a --- rho-type, so nothing to instantiate; just go straight to unify. --- It means we don't need to pass in a CtOrigin -tcWrapResultMono rn_expr expr act_ty res_ty - = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $ - do { co <- unifyExpectedType rn_expr act_ty res_ty - ; return (mkHsWrapCo co expr) } - -unifyExpectedType :: HsExpr GhcRn - -> TcRhoType -- Actual -- a rho-type not a sigma-type - -> ExpRhoType -- Expected - -> TcM TcCoercionN -unifyExpectedType rn_expr act_ty exp_ty - = case exp_ty of - Infer inf_res -> fillInferResult act_ty inf_res - Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty - ------------------------- -tcSubTypePat :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- Used in patterns; polarity is backwards compared --- to tcSubType --- If wrap = tc_sub_type_et t1 t2 --- => wrap :: t1 ~> t2 -tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected - = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected - -tcSubTypePat _ _ (Infer inf_res) ty_expected - = do { co <- fillInferResult ty_expected inf_res - -- In patterns we do not instantatiate - - ; return (mkWpCastN (mkSymCo co)) } - ---------------- -tcSubType :: CtOrigin -> UserTypeCtxt - -> TcSigmaType -- ^ Actual - -> ExpRhoType -- ^ Expected - -> TcM HsWrapper --- Checks that 'actual' is more polymorphic than 'expected' -tcSubType orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } - ---------------- -tcSubTypeDS :: HsExpr GhcRn - -> TcRhoType -- Actual -- a rho-type not a sigma-type - -> ExpRhoType -- Expected - -> TcM HsWrapper --- Similar signature to unifyExpectedType; does deep subsumption --- Only one call site, in GHC.Tc.Gen.App.tcApp -tcSubTypeDS rn_expr act_rho res_ty - = case res_ty of - Check exp_rho -> tc_sub_type_deep (unifyType m_thing) orig - GenSigCtxt act_rho exp_rho - - Infer inf_res -> do { co <- fillInferResult act_rho inf_res - ; return (mkWpCastN co) } - where - orig = exprCtOrigin rn_expr - m_thing = Just (HsExprRnThing rn_expr) - ---------------- -tcSubTypeNC :: CtOrigin -- ^ Used when instantiating - -> UserTypeCtxt -- ^ Used when skolemising - -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) - -> TcSigmaType -- ^ Actual type - -> ExpRhoType -- ^ Expected type - -> TcM HsWrapper -tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty - = case res_ty of - Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt - ty_actual ty_expected - - Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual - -- See Note [Instantiation of InferResult] - ; co <- fillInferResult rho inf_res - ; return (mkWpCastN co <.> wrap) } - ---------------- -tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we - -- doing this subtype check? - -> UserTypeCtxt -- where did the expected type arise? - -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- External entry point, but no ExpTypes on either side --- Checks that actual <= expected --- Returns HsWrapper :: actual ~ expected -tcSubTypeSigma orig ctxt ty_actual ty_expected - = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected - ---------------- -tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise - -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- See Note [Ambiguity check and deep subsumption] -tcSubTypeAmbiguity ctxt ty_actual ty_expected - = tc_sub_type_shallow (unifyType Nothing) - (AmbiguityCheckOrigin ctxt) - ctxt ty_actual ty_expected - ---------------- -addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a -addSubTypeCtxt ty_actual ty_expected thing_inside - | isRhoTy ty_actual -- If there is no polymorphism involved, the - , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) - = thing_inside -- gives enough context by itself - | otherwise - = addErrCtxtM mk_msg thing_inside - where - mk_msg tidy_env - = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual - ; ty_expected <- readExpType ty_expected - -- A worry: might not be filled if we're debugging. Ugh. - ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (text "When checking that:") - 4 (ppr ty_actual) - , nest 2 (hang (text "is more polymorphic than:") - 2 (ppr ty_expected)) ] - ; return (tidy_env, msg) } - - -{- Note [Instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We now always instantiate before filling in InferResult, so that -the result is a TcRhoType: see #17173 for discussion. - -For example: - -1. Consider - f x = (*) - We want to instantiate the type of (*) before returning, else we - will infer the type - f :: forall {a}. a -> forall b. Num b => b -> b -> b - This is surely confusing for users. - - And worse, the monomorphism restriction won't work properly. The MR is - dealt with in simplifyInfer, and simplifyInfer has no way of - instantiating. This could perhaps be worked around, but it may be - hard to know even when instantiation should happen. - -2. Another reason. Consider - f :: (?x :: Int) => a -> a - g y = let ?x = 3::Int in f - Here want to instantiate f's type so that the ?x::Int constraint - gets discharged by the enclosing implicit-parameter binding. - -3. Suppose one defines plus = (+). If we instantiate lazily, we will - infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism - restriction compels us to infer - plus :: Integer -> Integer -> Integer - (or similar monotype). Indeed, the only way to know whether to apply - the monomorphism restriction at all is to instantiate - -There is one place where we don't want to instantiate eagerly, -namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type -command. See Note [Implementing :type] in GHC.Tc.Module. --} - ---------------- -tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow - :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify - -> CtOrigin -- Used when instantiating - -> UserTypeCtxt -- Used when skolemising - -> TcSigmaType -- Actual; a sigma-type - -> TcSigmaType -- Expected; also a sigma-type - -> TcM HsWrapper --- Checks that actual_ty is more polymorphic than expected_ty --- If wrap = tc_sub_type t1 t2 --- => wrap :: t1 ~> t2 --- --- The "how to unify argument" is always a call to `uType TypeLevel orig`, --- but with different ways of constructing the CtOrigin `orig` from --- the argument types and context. - ----------------------- -tc_sub_type unify inst_orig ctxt ty_actual ty_expected - = do { deep_subsumption <- xoptM LangExt.DeepSubsumption - ; if deep_subsumption - then tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected - else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected - } - ----------------------- -tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , definitely_mono_shallow ty_actual - = do { traceTc "tc_sub_type (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - unify ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_type (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - - ; (sk_wrap, inner_wrap) - <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> - do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual - ; cow <- unify rho_a sk_rho - ; return (mkWpCastN cow <.> wrap) } - - ; return (sk_wrap <.> inner_wrap) } - ----------------------- -tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , definitely_mono_deep ty_actual - = do { traceTc "tc_sub_type_deep (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - unify ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_type_deep (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - - ; (sk_wrap, inner_wrap) - <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho -> - -- See Note [Deep subsumption] - tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho - - ; return (sk_wrap <.> inner_wrap) } - -definitely_mono_shallow :: TcType -> Bool -definitely_mono_shallow ty = isRhoTy ty - -- isRhoTy: no top level forall or (=>) - -definitely_mono_deep :: TcType -> Bool -definitely_mono_deep ty - | not (definitely_mono_shallow ty) = False - -- isRhoTy: False means top level forall or (=>) - | Just (_, res) <- tcSplitFunTy_maybe ty = definitely_mono_deep res - -- Top level (->) - | otherwise = True - -definitely_poly :: TcType -> Bool --- A very conservative test: --- see Note [Don't skolemise unnecessarily] -definitely_poly ty - | (tvs, theta, tau) <- tcSplitSigmaTy ty - , (tv:_) <- tvs -- At least one tyvar - , null theta -- No constraints; see (DP1) - , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs - -- The tyvar actually occurs (DP2), - -- and occurs in an injective position (DP3). - -- Fortunately checkTyVarEq, used for the occur check, - -- is just what we need. - = True - | otherwise - = False - -{- Note [Don't skolemise unnecessarily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are trying to solve - ty_actual <= ty_expected - (Char->Char) <= (forall a. a->a) -We could skolemise the 'forall a', and then complain -that (Char ~ a) is insoluble; but that's a pretty obscure -error. It's better to say that - (Char->Char) ~ (forall a. a->a) -fails. - -If we prematurely go to equality we'll reject a program we should -accept (e.g. #13752). So the test (which is only to improve error -message) is very conservative: - - * ty_actual is /definitely/ monomorphic: see `definitely_mono` - This definitely_mono test comes in "shallow" and "deep" variants - - * ty_expected is /definitely/ polymorphic: see `definitely_poly` - This definitely_poly test is more subtle than you might think. - Here are three cases where expected_ty looks polymorphic, but - isn't, and where it would be /wrong/ to switch to equality: - - (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) - - (DP2) (Char->Char) <= (forall a. Char -> Char) - - (DP3) (Char->Char) <= (forall a. F [a] Char -> Char) - where type instance F [x] t = t - - -Note [Wrapper returned from tcSubMult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no notion of multiplicity coercion in Core, therefore the wrapper -returned by tcSubMult (and derived functions such as tcCheckUsage and -checkManyPattern) is quite unlike any other wrapper: it checks whether the -coercion produced by the constraint solver is trivial, producing a type error -if it is not. This is implemented via the WpMultCoercion wrapper, as desugared -by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check. - -This wrapper needs to be placed in the term; otherwise, checking of the -eventual coercion won't be triggered during desugaring. But it can be put -anywhere, since it doesn't affect the desugared code. - -Why do we check this in the desugarer? It's a convenient place, since it's -right after all the constraints are solved. We need the constraints to be -solved to check whether they are trivial or not. - -An alternative would be to have a kind of constraint which can -only produce trivial evidence. This would allow such checks to happen -in the constraint solver (#18756). -This would be similar to the existing setup for Concrete, see - Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete - (PHASE 1 in particular). --} - -tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper -tcSubMult origin w_actual w_expected - | Just (w1, w2) <- isMultMul w_actual = - do { w1 <- tcSubMult origin w1 w_expected - ; w2 <- tcSubMult origin w2 w_expected - ; return (w1 <.> w2) } - -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is - -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p - -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating - -- multiplicities] in Multiplicity. -tcSubMult origin w_actual w_expected = - case submult w_actual w_expected of - Submult -> return WpHole - Unknown -> tcEqMult origin w_actual w_expected - -tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper -tcEqMult origin w_actual w_expected = do - { - -- Note that here we do not call to `submult`, so we check - -- for strict equality. - ; coercion <- uType TypeLevel origin w_actual w_expected - ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion } - - -{- ********************************************************************* -* * - Deep subsumption -* * -********************************************************************* -} - -{- Note [Deep subsumption] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The DeepSubsumption extension, documented here - - https://github.com/ghc-proposals/ghc-proposals/pull/511. - -makes a best-efforts attempt implement deep subsumption as it was -prior to the Simplify Subsumption proposal: - - https://github.com/ghc-proposals/ghc-proposals/pull/287 - -The effects are in these main places: - -1. In the subsumption check, tcSubType, we must do deep skolemisation: - see the call to tcDeeplySkolemise in tc_sub_type_deep - -2. In tcPolyExpr we must do deep skolemisation: - see the call to tcDeeplySkolemise in tcSkolemiseExpType - -3. for expression type signatures (e :: ty), and functions with type - signatures (e.g. f :: ty; f = e), we must deeply skolemise the type; - see the call to tcDeeplySkolemise in tcSkolemiseScoped. - -4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result - type. Without deep subsumption, unifyExpectedType would be sufficent. - -In all these cases note that the deep skolemisation must be done /first/. -Consider (1) - (forall a. Int -> a -> a) <= Int -> (forall b. b -> b) -We must skolemise the `forall b` before instantiating the `forall a`. -See also Note [Deep skolemisation]. - -Note that we /always/ use shallow subsumption in the ambiguity check. -See Note [Ambiguity check and deep subsumption]. - -Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -deeplySkolemise decomposes and skolemises a type, returning a type -with all its arrows visible (ie not buried under foralls) - -Examples: - - deeplySkolemise (Int -> forall a. Ord a => blah) - = ( wp, [a], [d:Ord a], Int -> blah ) - where wp = \x:Int. /\a. \(d:Ord a). x - - deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) - where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x - -In general, - if deeplySkolemise ty = (wrap, tvs, evs, rho) - and e :: rho - then wrap e :: ty - and 'wrap' binds tvs, evs - -ToDo: this eta-abstraction plays fast and loose with termination, - because it can introduce extra lambdas. Maybe add a `seq` to - fix this - -Note [Setting the argument context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we are doing the ambiguity check for the (bogus) - f :: (forall a b. C b => a -> a) -> Int - -We'll call - tcSubType ((forall a b. C b => a->a) -> Int ) - ((forall a b. C b => a->a) -> Int ) - -with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing -on the argument type of the (->) -- and at that point we want to switch -to a UserTypeCtxt of GenSigCtxt. Why? - -* Error messages. If we stick with FunSigCtxt we get errors like - * Could not deduce: C b - from the context: C b0 - bound by the type signature for: - f :: forall a b. C b => a->a - But of course f does not have that type signature! - Example tests: T10508, T7220a, Simple14 - -* Implications. We may decide to build an implication for the whole - ambiguity check, but we don't need one for each level within it, - and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. - See Note [When to build an implication] - -Note [Multiplicity in deep subsumption] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - t1 ->{mt} t2 <= s1 ->{ms} s2 - -At the moment we /unify/ ms~mt, via tcEqMult. - -Arguably we should use `tcSubMult`. But then if mt=m0 (a unification -variable) and ms=Many, `tcSubMult` is a no-op (since anything is a -sub-multiplicty of Many). But then `m0` may never get unified with -anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds -Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base -we get this - - "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys - = \xs -> xs ++ ys - -where we eta-expanded that (:). But now foldr expects an argument -with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint -complains. - -The easiest solution was to use tcEqMult in tc_sub_type_ds, and -insist on equality. This is only in the DeepSubsumption code anyway. --} - -tc_sub_type_ds :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify - -> CtOrigin -- Used when instantiating - -> UserTypeCtxt -- Used when skolemising - -> TcSigmaType -- Actual; a sigma-type - -> TcRhoType -- Expected; deeply skolemised - -> TcM HsWrapper - --- If wrap = tc_sub_type_ds t1 t2 --- => wrap :: t1 ~> t2 --- Here is where the work actually happens! --- Precondition: ty_expected is deeply skolemised - -tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected - = do { traceTc "tc_sub_type_ds" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; go ty_actual ty_expected } - where - -- NB: 'go' is not recursive, except for doing coreView - go ty_a ty_e | Just ty_a' <- coreView ty_a = go ty_a' ty_e - | Just ty_e' <- coreView ty_e = go ty_a ty_e' - - go (TyVarTy tv_a) ty_e - = do { lookup_res <- isFilledMetaTyVar_maybe tv_a - ; case lookup_res of - Just ty_a' -> - do { traceTc "tc_sub_type_ds following filled meta-tyvar:" - (ppr tv_a <+> text "-->" <+> ppr ty_a') - ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e } - Nothing -> just_unify ty_actual ty_expected } - - go ty_a@(FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) - ty_e@(FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) - | isVisibleFunArg af1, isVisibleFunArg af2 - = if (isTauTy ty_a && isTauTy ty_e) -- Short cut common case to avoid - then just_unify ty_actual ty_expected -- unnecessary eta expansion - else - -- This is where we do the co/contra thing, and generate a WpFun, which in turn - -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption - do { arg_wrap <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg - -- GenSigCtxt: See Note [Setting the argument context] - ; res_wrap <- tc_sub_type_ds unify inst_orig ctxt act_res exp_res - ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult - -- See Note [Multiplicity in deep subsumption] - ; return (mult_wrap <.> - mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) } - -- arg_wrap :: exp_arg ~> act_arg - -- res_wrap :: act-res ~> exp_res - where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) - - go ty_a ty_e - | let (tvs, theta, _) = tcSplitSigmaTy ty_a - , not (null tvs && null theta) - = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a - ; body_wrap <- tc_sub_type_ds unify inst_orig ctxt in_rho ty_e - ; return (body_wrap <.> in_wrap) } - - | otherwise -- Revert to unification - = do { -- It's still possible that ty_actual has nested foralls. Instantiate - -- these, as there's no way unification will succeed with them in. - -- See typecheck/should_compile/T11305 for an example of when this - -- is important. The problem is that we're checking something like - -- a -> forall b. b -> b <= alpha beta gamma - -- where we end up with alpha := (->) - (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual - ; unify_wrap <- just_unify rho_a ty_expected - ; return (unify_wrap <.> inst_wrap) } - - just_unify ty_a ty_e = do { cow <- unify ty_a ty_e - ; return (mkWpCastN cow) } - -tcDeeplySkolemise - :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) - -> TcM (HsWrapper, result) - -- ^ The wrapper has type: spec_ty ~> expected_ty --- Just like tcTopSkolemise, but calls --- deeplySkolemise instead of topSkolemise --- See Note [Deep skolemisation] -tcDeeplySkolemise ctxt expected_ty thing_inside - | isTauTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty - ; return (idHsWrapper, res) } - | otherwise - = do { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise; - -- but skol_info can't be built until we have tv_prs - rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs) - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - -deeplySkolemise :: SkolemInfo -> TcSigmaType - -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s - , TcRhoType ) --- See Note [Deep skolemisation] -deeplySkolemise skol_info ty - = go init_subst ty - where - init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty - = do { let arg_tys' = substScaledTys subst arg_tys - ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs - ; ev_vars1 <- newEvVars (substTheta subst' theta) - ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpEta ids1 (mkWpTyLams tvs1 - <.> mkWpEvLams ev_vars1 - <.> wrap) - , tv_prs1 ++ tvs_prs2 - , ev_vars1 ++ ev_vars2 - , mkScaledFunTys arg_tys' rho ) } - - | otherwise - = return (idHsWrapper, [], [], substTy subst ty) - -- substTy is a quick no-op on an empty substitution - -deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) -deeplyInstantiate orig ty - = go init_subst ty - where - init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (subst', tvs') <- newMetaTyVarsX subst tvs - ; let arg_tys' = substScaledTys subst' arg_tys - theta' = substTheta subst' theta - ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' - ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' - ; (wrap2, rho2) <- go subst' rho - ; return (mkWpEta ids1 (wrap2 <.> wrap1), - mkScaledFunTys arg_tys' rho2) } - - | otherwise - = do { let ty' = substTy subst ty - ; return (idHsWrapper, ty') } - -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) --- Looks for a *non-trivial* quantified type, under zero or more function arrows --- By "non-trivial" we mean either tyvars or constraints are non-empty - -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) - - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) - - | otherwise = Nothing - - -{- ********************************************************************* -* * - Generalisation -* * -********************************************************************* -} - -{- Note [Skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~ -tcTopSkolemise takes "expected type" and strip off quantifiers to expose the -type underneath, binding the new skolems for the 'thing_inside' -The returned 'HsWrapper' has type (specific_ty -> expected_ty). - -Note that for a nested type like - forall a. Eq a => forall b. Ord b => blah -we still only build one implication constraint - forall a b. (Eq a, Ord b) => -This is just an optimisation, but it's why we use topSkolemise to -build the pieces from all the layers, before making a single call -to checkConstraints. - -tcSkolemiseScoped is very similar, but differs in two ways: - -* It deals specially with just the outer forall, bringing those type - variables into lexical scope. To my surprise, I found that doing - this unconditionally in tcTopSkolemise (i.e. doing it even if we don't - need to bring the variables into lexical scope, which is harmless) - caused a non-trivial (1%-ish) perf hit on the compiler. - -* It handles deep subumption, wheres tcTopSkolemise never looks under - function arrows. - -* It always calls checkConstraints, even if there are no skolem - variables at all. Reason: there might be nested deferred errors - that must not be allowed to float to top level. - See Note [When to build an implication] below. --} - -tcTopSkolemise, tcSkolemiseScoped - :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) - -> TcM (HsWrapper, result) - -- ^ The wrapper has type: spec_ty ~> expected_ty --- See Note [Skolemisation] for the differences between --- tcSkolemiseScoped and tcTopSkolemise - -tcSkolemiseScoped ctxt expected_ty thing_inside - = do { deep_subsumption <- xoptM LangExt.DeepSubsumption - ; let skolemise | deep_subsumption = deeplySkolemise - | otherwise = topSkolemise - ; -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, res) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, res) } - -tcTopSkolemise ctxt expected_ty thing_inside - | isRhoTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty - ; return (idHsWrapper, res) } - | otherwise - = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - --- | Variant of 'tcTopSkolemise' that takes an ExpType -tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) - -> TcM (HsWrapper, result) -tcSkolemiseExpType _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et -tcSkolemiseExpType ctxt (Check ty) thing_inside - = do { deep_subsumption <- xoptM LangExt.DeepSubsumption - ; let skolemise | deep_subsumption = tcDeeplySkolemise - | otherwise = tcTopSkolemise - ; skolemise ctxt ty $ \rho_ty -> - thing_inside (mkCheckExpType rho_ty) } - -checkConstraints :: SkolemInfoAnon - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> TcM result - -> TcM (TcEvBinds, result) - -checkConstraints skol_info skol_tvs given thing_inside - = do { implication_needed <- implicationNeeded skol_info skol_tvs given - - ; if implication_needed - then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted - ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) - ; emitImplications implics - ; return (ev_binds, result) } - - else -- Fast path. We check every function argument with tcCheckPolyExpr, - -- which uses tcTopSkolemise and hence checkConstraints. - -- So this fast path is well-exercised - do { res <- thing_inside - ; return (emptyTcEvBinds, res) } } - -checkTvConstraints :: SkolemInfo - -> [TcTyVar] -- Skolem tyvars - -> TcM result - -> TcM result - -checkTvConstraints skol_info skol_tvs thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted - ; return result } - -emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM () -emitResidualTvConstraint skol_info skol_tvs tclvl wanted - | not (isEmptyWC wanted) || - checkTelescopeSkol skol_info_anon - = -- checkTelescopeSkol: in this case, /always/ emit this implication - -- even if 'wanted' is empty. We need the implication so that we check - -- for a bad telescope. See Note [Skolem escape and forall-types] in - -- GHC.Tc.Gen.HsType - do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted - ; emitImplication implic } - - | otherwise -- Empty 'wanted', emit nothing - = return () - where - skol_info_anon = getSkolemInfo skol_info - -buildTvImplication :: SkolemInfoAnon -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM Implication -buildTvImplication skol_info skol_tvs tclvl wanted - = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ - do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints - -- are solved by filling in coercion holes, not - -- by creating a value-level evidence binding - ; implic <- newImplication - - ; let implic' = implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given_eqs = NoGivenEqs - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info } - - ; checkImplicationInvariants implic' - ; return implic' } - -implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool --- See Note [When to build an implication] -implicationNeeded skol_info skol_tvs given - | null skol_tvs - , null given - , not (alwaysBuildImplication skol_info) - = -- Empty skolems and givens - do { tc_lvl <- getTcLevel - ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are - then return False -- already inside an implication - else - do { dflags <- getDynFlags -- If any deferral can happen, - -- we must build an implication - ; return (gopt Opt_DeferTypeErrors dflags || - gopt Opt_DeferTypedHoles dflags || - gopt Opt_DeferOutOfScopeVariables dflags) } } - - | otherwise -- Non-empty skolems or givens - = return True -- Definitely need an implication - -alwaysBuildImplication :: SkolemInfoAnon -> Bool --- See Note [When to build an implication] -alwaysBuildImplication _ = False - -{- Commmented out for now while I figure out about error messages. - See #14185 - -alwaysBuildImplication (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt {} -> True -- RHS of a binding with a signature - _ -> False -alwaysBuildImplication (RuleSkol {}) = True -alwaysBuildImplication (InstSkol {}) = True -alwaysBuildImplication (FamInstSkol {}) = True -alwaysBuildImplication _ = False --} - -buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] - -> [EvVar] -> WantedConstraints - -> TcM (Bag Implication, TcEvBinds) -buildImplicationFor tclvl skol_info skol_tvs given wanted - | isEmptyWC wanted && null given - -- Optimisation : if there are no wanteds, and no givens - -- don't generate an implication at all. - -- Reason for the (null given): we don't want to lose - -- the "inaccessible alternative" error check - = return (emptyBag, emptyTcEvBinds) - - | otherwise - = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ - -- Why allow TyVarTvs? Because implicitly declared kind variables in - -- non-CUSK type declarations are TyVarTvs, and we need to bring them - -- into scope as a skolem in an implication. This is OK, though, - -- because TyVarTvs will always remain tyvars, even after unification. - do { ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given = given - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = skol_info } - ; checkImplicationInvariants implic' - - ; return (unitBag implic', TcEvBinds ev_binds_var) } - -{- Note [When to build an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have some 'skolems' and some 'givens', and we are -considering whether to wrap the constraints in their scope into an -implication. We must /always/ so if either 'skolems' or 'givens' are -non-empty. But what if both are empty? You might think we could -always drop the implication. Other things being equal, the fewer -implications the better. Less clutter and overhead. But we must -take care: - -* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, - we'll make a /term-level/ evidence binding for 'g = error "blah"'. - We must have an EvBindsVar those bindings!, otherwise they end up as - top-level unlifted bindings, which are verboten. This only matters - at top level, so we check for that - See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors. - cf #14149 for an example of what goes wrong. - -* If you have - f :: Int; f = f_blah - g :: Bool; g = g_blah - If we don't build an implication for f or g (no tyvars, no givens), - the constraints for f_blah and g_blah are solved together. And that - can yield /very/ confusing error messages, because we can get - [W] C Int b1 -- from f_blah - [W] C Int b2 -- from g_blan - and fundpes can yield [W] b1 ~ b2, even though the two functions have - literally nothing to do with each other. #14185 is an example. - Building an implication keeps them separate. --} - -{- -************************************************************************ -* * - Boxy unification -* * -************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. --} - -unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 - -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) - -> TcM TcCoercionN -- :: ty1 ~# ty2 --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyType thing ty1 ty2 - = uType TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = thing - , uo_visible = True } - -unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN --- Like unifyType, but swap expected and actual in error messages --- This is used when typechecking patterns -unifyTypeET ty1 ty2 - = uType TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped - , uo_expected = ty1 -- NB swapped - , uo_thing = Nothing - , uo_visible = True } - - -unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN -unifyKind mb_thing ty1 ty2 - = uType KindLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = mb_thing - , uo_visible = True } - - -{- -%************************************************************************ -%* * - uType and friends -%* * -%************************************************************************ - -uType is the heart of the unifier. --} - -uType, uType_defer - :: TypeOrKind - -> CtOrigin - -> TcType -- ty1 is the *actual* type - -> TcType -- ty2 is the *expected* type - -> TcM CoercionN - --------------- --- It is always safe to defer unification to the main constraint solver --- See Note [Deferred unification] --- ty1 is "actual" --- ty2 is "expected" -uType_defer t_or_k origin ty1 ty2 - = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 - - -- Error trace only - -- NB. do *not* call mkErrInfo unless tracing is on, - -- because it is hugely expensive (#5631) - ; whenDOptM Opt_D_dump_tc_trace $ do - { ctxt <- getErrCtxt - ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ debugPprType ty1 - , debugPprType ty2 - , pprCtOrigin origin - , doc]) - ; traceTc "utype_defer2" (ppr co) - } - ; return co } - --------------- -uType t_or_k origin orig_ty1 orig_ty2 - = do { tclvl <- getTcLevel - ; traceTc "u_tys" $ vcat - [ text "tclvl" <+> ppr tclvl - , sep [ ppr orig_ty1, text "~", ppr orig_ty2] - , pprCtOrigin origin] - ; co <- go orig_ty1 orig_ty2 - ; if isReflCo co - then traceTc "u_tys yields no coercion" Outputable.empty - else traceTc "u_tys yields coercion:" (ppr co) - ; return co } - where - go :: TcType -> TcType -> TcM CoercionN - -- The arguments to 'go' are always semantically identical - -- to orig_ty{1,2} except for looking through type synonyms - - -- Unwrap casts before looking for variables. This way, we can easily - -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we - -- didn't do it this way, and then the unification above was deferred. - go (CastTy t1 co1) t2 - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) } - - go t1 (CastTy t2 co2) - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) } - - -- Variables; go for uUnfilledVar - -- Note that we pass in *original* (before synonym expansion), - -- so that type variables tend to get filled in with - -- the most informative version of the type - go (TyVarTy tv1) ty2 - = do { lookup_res <- isFilledMetaTyVar_maybe tv1 - ; case lookup_res of - Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) - ; go ty1 ty2 } - Nothing -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } - go ty1 (TyVarTy tv2) - = do { lookup_res <- isFilledMetaTyVar_maybe tv2 - ; case lookup_res of - Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) - ; go ty1 ty2 } - Nothing -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 } - - -- See Note [Expanding synonyms during unification] - go ty1@(TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = return $ mkNomReflCo ty1 - - -- See Note [Expanding synonyms during unification] - -- - -- Also NB that we recurse to 'go' so that we don't push a - -- new item on the origin stack. As a result if we have - -- type Foo = Int - -- and we try to unify Foo ~ Bool - -- we'll end up saying "can't match Foo with Bool" - -- rather than "can't match "Int with Bool". See #4535. - go ty1 ty2 - | Just ty1' <- coreView ty1 = go ty1' ty2 - | Just ty2' <- coreView ty2 = go ty1 ty2' - - -- Functions (t1 -> t2) just check the two parts - -- Do not attempt (c => t); just defer - go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) - | isVisibleFunArg af1, af1 == af2 - = do { co_l <- uType t_or_k origin arg1 arg2 - ; co_r <- uType t_or_k origin res1 res2 - ; co_w <- uType t_or_k origin w1 w2 - ; return $ mkNakedFunCo1 Nominal af1 co_w co_l co_r } - - -- Always defer if a type synonym family (type function) - -- is involved. (Data families behave rigidly.) - go ty1@(TyConApp tc1 _) ty2 - | isTypeFamilyTyCon tc1 = defer ty1 ty2 - go ty1 ty2@(TyConApp tc2 _) - | isTypeFamilyTyCon tc2 = defer ty1 ty2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - -- See Note [Mismatched type lists and application decomposition] - | tc1 == tc2, equalLength tys1 tys2 - = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $ - do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2 - ; return $ mkTyConAppCo Nominal tc1 cos } - where - origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin) - (tcTyConVisibilities tc1) - - go (LitTy m) ty@(LitTy n) - | m == n - = return $ mkNomReflCo ty - - -- See Note [Care with type applications] - -- Do not decompose FunTy against App; - -- it's often a type error, so leave it for the constraint solver - go (AppTy s1 t1) (AppTy s2 t2) - = go_app (isNextArgVisible s1) s1 t1 s2 t2 - - go (AppTy s1 t1) (TyConApp tc2 ts2) - | Just (ts2', t2') <- snocView ts2 - = assert (not (tyConMustBeSaturated tc2)) $ - go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2' - - go (TyConApp tc1 ts1) (AppTy s2 t2) - | Just (ts1', t1') <- snocView ts1 - = assert (not (tyConMustBeSaturated tc1)) $ - go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 - - go (CoercionTy co1) (CoercionTy co2) - = do { let ty1 = coercionType co1 - ty2 = coercionType co2 - ; kco <- uType KindLevel - (KindEqOrigin orig_ty1 orig_ty2 origin - (Just t_or_k)) - ty1 ty2 - ; return $ mkProofIrrelCo Nominal kco co1 co2 } - - -- Anything else fails - -- E.g. unifying for-all types, which is relative unusual - go ty1 ty2 = defer ty1 ty2 - - ------------------ - defer ty1 ty2 -- See Note [Check for equality before deferring] - | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1) - | otherwise = uType_defer t_or_k origin ty1 ty2 - - ------------------ - go_app vis s1 t1 s2 t2 - = do { co_s <- uType t_or_k origin s1 s2 - ; let arg_origin - | vis = origin - | otherwise = toInvisibleOrigin origin - ; co_t <- uType t_or_k arg_origin t1 t2 - ; return $ mkAppCo co_s co_t } - -{- Note [Check for equality before deferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Particularly in ambiguity checks we can get equalities like (ty ~ ty). -If ty involves a type function we may defer, which isn't very sensible. -An egregious example of this was in test T9872a, which has a type signature - Proxy :: Proxy (Solutions Cubes) -Doing the ambiguity check on this signature generates the equality - Solutions Cubes ~ Solutions Cubes -and currently the constraint solver normalises both sides at vast cost. -This little short-cut in 'defer' helps quite a bit. - -Note [Care with type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note: type applications need a bit of care! -They can match FunTy and TyConApp, so use splitAppTy_maybe -NB: we've already dealt with type variables and Notes, -so if one type is an App the other one jolly well better be too - -Note [Mismatched type lists and application decomposition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we find two TyConApps, you might think that the argument lists -are guaranteed equal length. But they aren't. Consider matching - w (T x) ~ Foo (T x y) -We do match (w ~ Foo) first, but in some circumstances we simply create -a deferred constraint; and then go ahead and match (T x ~ T x y). -This came up in #3950. - -So either - (a) either we must check for identical argument kinds - when decomposing applications, - - (b) or we must be prepared for ill-kinded unification sub-problems - -Currently we adopt (b) since it seems more robust -- no need to maintain -a global invariant. - -Note [Expanding synonyms during unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We expand synonyms during unification, but: - * We expand *after* the variable case so that we tend to unify - variables with un-expanded type synonym. This just makes it - more likely that the inferred types will mention type synonyms - understandable to the user - - * Similarly, we expand *after* the CastTy case, just in case the - CastTy wraps a variable. - - * We expand *before* the TyConApp case. For example, if we have - type Phantom a = Int - and are unifying - Phantom Int ~ Phantom Char - it is *wrong* to unify Int and Char. - - * The problem case immediately above can happen only with arguments - to the tycon. So we check for nullary tycons *before* expanding. - This is particularly helpful when checking (* ~ *), because * is - now a type synonym. - -Note [Deferred unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, -and yet its consistency is undetermined. Previously, there was no way to still -make it consistent. So a mismatch error was issued. - -Now these unifications are deferred until constraint simplification, where type -family instances and given equations may (or may not) establish the consistency. -Deferred unifications are of the form - F ... ~ ... -or x ~ ... -where F is a type function and x is a type variable. -E.g. - id :: x ~ y => x -> y - id e = e - -involves the unification x = y. It is deferred until we bring into account the -context x ~ y to establish that it holds. - -If available, we defer original types (rather than those where closed type -synonyms have already been expanded via tcCoreView). This is, as usual, to -improve error messages. - -************************************************************************ -* * - uUnfilledVar and friends -* * -************************************************************************ - -@uunfilledVar@ is called when at least one of the types being unified is a -variable. It does {\em not} assume that the variable is a fixed point -of the substitution; rather, notice that @uVar@ (defined below) nips -back into @uTys@ if it turns out that the variable is already bound. --} - ----------- -uUnfilledVar :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2 - -> TcM Coercion --- "Unfilled" means that the variable is definitely not a filled-in meta tyvar --- It might be a skolem, or untouchable, or meta - -uUnfilledVar origin t_or_k swapped tv1 ty2 - = do { ty2 <- zonkTcType ty2 - -- Zonk to expose things to the - -- occurs check, and so that if ty2 - -- looks like a type variable then it - -- /is/ a type variable - ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 } - ----------- -uUnfilledVar1 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- getTyVar_maybe ty2 - = go tv2 - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - - where - -- 'go' handles the case where both are - -- tyvars so we might want to swap - -- E.g. maybe tv2 is a meta-tyvar and tv1 is not - go tv2 | tv1 == tv2 -- Same type variable => no-op - = return (mkNomReflCo (mkTyVarTy tv1)) - - | swapOverTyVars False tv1 tv2 -- Distinct type variables - -- Swap meta tyvar to the left if poss - = do { tv1 <- zonkTyCoVarKind tv1 - -- We must zonk tv1's kind because that might - -- not have happened yet, and it's an invariant of - -- uUnfilledTyVar2 that ty2 is fully zonked - -- Omitting this caused #16902 - ; uUnfilledVar2 origin t_or_k (flipSwap swapped) - tv2 (mkTyVarTy tv1) } - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - ----------- -uUnfilledVar2 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar2 origin t_or_k swapped tv1 ty2 - = do { cur_lvl <- getTcLevel - ; go cur_lvl } - where - go cur_lvl - | isTouchableMetaTyVar cur_lvl tv1 - -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles - , cterHasNoProblem (checkTyVarEq tv1 ty2) - -- See Note [Prevent unification with type families] - = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2 - ; case mb_continue_solving of - { Nothing -> not_ok_so_defer - ; Just ty2 -> - do { co_k <- uType KindLevel kind_origin (typeKind ty2) (tyVarKind tv1) - ; traceTc "uUnfilledVar2 ok" $ - vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) - , ppr (isReflCo co_k), ppr co_k ] - - ; if isReflCo co_k - -- Only proceed if the kinds match - -- NB: tv1 should still be unfilled, despite the kind unification - -- because tv1 is not free in ty2 (or, hence, in its kind) - then do { writeMetaTyVar tv1 ty2 - ; return (mkNomReflCo ty2) } - - else defer }}} -- This cannot be solved now. See GHC.Tc.Solver.Canonical - -- Note [Equalities with incompatible kinds] for how - -- this will be dealt with in the solver - - | otherwise - = not_ok_so_defer - - ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k) - - defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 - - not_ok_so_defer = - do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) - -- Occurs check or an untouchable: just defer - -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occurred in type family parameter - ; defer } - --- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of --- Note [Unification preconditions]; returns True if these conditions --- are satisfied. But see the Note for other preconditions, too. -startSolvingByUnification :: MetaInfo -> TcType -- zonked - -> TcM (Maybe TcType) -startSolvingByUnification _ xi - | hasCoercionHoleTy xi -- (COERCION-HOLE) check - = return Nothing -startSolvingByUnification info xi - = case info of - CycleBreakerTv -> return Nothing - ConcreteTv conc_orig -> - do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi - -- NB: makeTypeConcrete has the side-effect of turning - -- some TauTvs into ConcreteTvs, e.g. - -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ]) - -- will write `beta[tau] := beta[conc]`. - -- - -- We return the new type, so that callers of this function - -- aren't required to zonk. - ; case not_conc_reasons of - [] -> return $ Just xi - _ -> return Nothing } - TyVarTv -> - case getTyVar_maybe xi of - Nothing -> return Nothing - Just tv -> - case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle - SkolemTv {} -> return $ Just xi - RuntimeUnk -> return $ Just xi - MetaTv { mtv_info = info } -> - case info of - TyVarTv -> return $ Just xi - _ -> return Nothing - _ -> return $ Just xi - -swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool -swapOverTyVars is_given tv1 tv2 - -- See Note [Unification variables on the left] - | not is_given, pri1 == 0, pri2 > 0 = True - | not is_given, pri2 == 0, pri1 > 0 = False - - -- Level comparison: see Note [TyVar/TyVar orientation] - | lvl1 `strictlyDeeperThan` lvl2 = False - | lvl2 `strictlyDeeperThan` lvl1 = True - - -- Priority: see Note [TyVar/TyVar orientation] - | pri1 > pri2 = False - | pri2 > pri1 = True - - -- Names: see Note [TyVar/TyVar orientation] - | isSystemName tv2_name, not (isSystemName tv1_name) = True - - | otherwise = False - - where - lvl1 = tcTyVarLevel tv1 - lvl2 = tcTyVarLevel tv2 - pri1 = lhsPriority tv1 - pri2 = lhsPriority tv2 - tv1_name = Var.varName tv1 - tv2_name = Var.varName tv2 - - -lhsPriority :: TcTyVar -> Int --- Higher => more important to be on the LHS --- => more likely to be eliminated --- See Note [TyVar/TyVar orientation] -lhsPriority tv - = assertPpr (isTyVar tv) (ppr tv) $ - case tcTyVarDetails tv of - RuntimeUnk -> 0 - SkolemTv {} -> 0 - MetaTv { mtv_info = info } -> case info of - CycleBreakerTv -> 0 - TyVarTv -> 1 - ConcreteTv {} -> 2 - TauTv -> 3 - RuntimeUnkTv -> 4 - -{- Note [Unification preconditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Question: given a homogeneous equality (alpha ~# ty), when is it OK to -unify alpha := ty? - -This note only applied to /homogeneous/ equalities, in which both -sides have the same kind. - -There are five reasons not to unify: - -1. (SKOL-ESC) Skolem-escape - Consider the constraint - forall[2] a[2]. alpha[1] ~ Maybe a[2] - If we unify alpha := Maybe a, the skolem 'a' may escape its scope. - The level alpha[1] says that alpha may be used outside this constraint, - where 'a' is not in scope at all. So we must not unify. - - Bottom line: when looking at a constraint alpha[n] := ty, do not unify - if any free variable of 'ty' has level deeper (greater) than n - -2. (UNTOUCHABLE) Untouchable unification variables - Consider the constraint - forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int - There is no (SKOL-ESC) problem with unifying alpha := Int, but it might - not be the principal solution. Perhaps the "right" solution is alpha := b. - We simply can't tell. See "OutsideIn(X): modular type inference with local - assumptions", section 2.2. We say that alpha[1] is "untouchable" inside - this implication. - - Bottom line: at ambient level 'l', when looking at a constraint - alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities - between levels 'n' and 'l'. - - Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)? - Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet - -3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs - This precondition looks at the MetaInfo of the unification variable: - - * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a - TyVarTv it can only unify with a type variable, not with a - structured type. So if 'ty' is a structured type, such as (Maybe x), - don't unify. - - * CycleBreakerTv: never unified, except by restoreTyVarCycles. - -4. (CONCRETE) A ConcreteTv can only unify with a concrete type, - by definition. - - That is, if we have `rr[conc] ~ F Int`, we can't unify - `rr` with `F Int`, so we hold off on unifying. - Note however that the equality might get rewritten; for instance - if we can rewrite `F Int` to a concrete type, say `FloatRep`, - then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. - - Note that we can still make progress on unification even if - we can't fully solve an equality, e.g. - - alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ] - - we can fill beta[tau] := beta[conc]. This is why we call - 'makeTypeConcrete' in startSolvingByUnification. - -5. (COERCION-HOLE) Confusing coercion holes - Suppose our equality is - (alpha :: k) ~ (Int |> {co}) - where co :: Type ~ k is an unsolved wanted. Note that this - equality is homogeneous; both sides have kind k. Unifying here - is sensible, but it can lead to very confusing error messages. - It's very much like a Wanted rewriting a Wanted. Even worse, - unifying a variable essentially turns an equality into a Given, - and so we could not use the tracking mechanism in - Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. - We thus simply do not unify in this case. - - This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds] - in GHC.Tc.Solver.Canonical. - - -Needless to say, all there are wrinkles: - -* (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free - in 'ty', where beta is a unification variable, and k>n? 'beta' - stands for a monotype, and since it is part of a level-n type - (equal to alpha[n]), we must /promote/ beta to level n. Just make - up a fresh gamma[n], and unify beta[k] := gamma[n]. - -* (TYVAR-TV) Unification variables. Suppose alpha[tyv,n] is a level-n - TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now - consider alpha[tyv,n] ~ Bool. We don't want to unify because that - would break the TyVarTv invariant. - - What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary - TauTv? Again, don't unify, because beta might later be unified - with, say Bool. (If levels permit, we reverse the orientation here; - see Note [TyVar/TyVar orientation].) - -* (UNTOUCHABLE) Untouchability. When considering (alpha[n] ~ ty), how - do we know whether there are any given equalities between level n - and the ambient level? We answer in two ways: - - * In the eager unifier, we only unify if l=n. If not, alpha may be - untouchable, and defer to the constraint solver. This check is - made in GHC.Tc.Utils.uUnifilledVar2, in the guard - isTouchableMetaTyVar. - - * In the constraint solver, we track where Given equalities occur - and use that to guard unification in GHC.Tc.Solver.Canonical.touchabilityTest - More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet - - Historical note: in the olden days (pre 2021) the constraint solver - also used to unify only if l=n. Equalities were "floated" out of the - implication in a separate step, so that they would become touchable. - But the float/don't-float question turned out to be very delicate, - as you can see if you look at the long series of Notes associated with - GHC.Tc.Solver.floatEqualities, around Nov 2020. It's much easier - to unify in-place, with no floating. - -Note [TyVar/TyVar orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Fundeps with instances, and equality orientation] -where the kind equality orientation is important - -Given (a ~ b), should we orient the CEqCan as (a~b) or (b~a)? -This is a surprisingly tricky question! This is invariant (TyEq:TV). - -The question is answered by swapOverTyVars, which is used - - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 - - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqCanLHS2 - -First note: only swap if you have to! - See Note [Avoid unnecessary swaps] - -So we look for a positive reason to swap, using a three-step test: - -* Level comparison. If 'a' has deeper level than 'b', - put 'a' on the left. See Note [Deeper level on the left] - -* Priority. If the levels are the same, look at what kind of - type variable it is, using 'lhsPriority'. - - Generally speaking we always try to put a MetaTv on the left - in preference to SkolemTv or RuntimeUnkTv: - a) Because the MetaTv may be touchable and can be unified - b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints - looks for meta tyvars on the left - - Tie-breaking rules for MetaTvs: - - CycleBreakerTv: This is essentially a stand-in for another type; - it's untouchable and should have the same priority as a skolem: 0. - - - TyVarTv: These can unify only with another tyvar, but we can't unify - a TyVarTv with a TauTv, because then the TyVarTv could (transitively) - get a non-tyvar type. So give these a low priority: 1. - - - ConcreteTv: These are like TauTv, except they can only unify with - a concrete type. So we want to be able to write to them, but not quite - as much as TauTvs: 2. - - - TauTv: This is the common case; we want these on the left so that they - can be written to: 3. - - - RuntimeUnkTv: These aren't really meta-variables used in type inference, - but just a convenience in the implementation of the GHCi debugger. - Eagerly write to these: 4. See Note [RuntimeUnkTv] in - GHC.Runtime.Heap.Inspect. - -* Names. If the level and priority comparisons are all - equal, try to eliminate a TyVar with a System Name in - favour of ones with a Name derived from a user type signature - -* Age. At one point in the past we tried to break any remaining - ties by eliminating the younger type variable, based on their - Uniques. See Note [Eliminate younger unification variables] - (which also explains why we don't do this any more) - -Note [Unification variables on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of -level, so that the unification variable is on the left. - -* We /don't/ want this for Givens because if we ave - [G] a[2] ~ alpha[1] - [W] Bool ~ a[2] - we want to rewrite the wanted to Bool ~ alpha[1], - so we can float the constraint and solve it. - -* But for Wanteds putting the unification variable on - the left means an easier job when floating, and when - reporting errors -- just fewer cases to consider. - - In particular, we get better skolem-escape messages: - see #18114 - -Note [Deeper level on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The most important thing is that we want to put tyvars with -the deepest level on the left. The reason to do so differs for -Wanteds and Givens, but either way, deepest wins! Simple. - -* Wanteds. Putting the deepest variable on the left maximise the - chances that it's a touchable meta-tyvar which can be solved. - -* Givens. Suppose we have something like - forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] - - If we orient the Given a[2] on the left, we'll rewrite the Wanted to - (beta[1] ~ b[1]), and that can float out of the implication. - Otherwise it can't. By putting the deepest variable on the left - we maximise our changes of eliminating skolem capture. - - See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason - to orient with the deepest skolem on the left. - - IMPORTANT NOTE: this test does a level-number comparison on - skolems, so it's important that skolems have (accurate) level - numbers. - -See #15009 for an further analysis of why "deepest on the left" -is a good plan. - -Note [Avoid unnecessary swaps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we swap without actually improving matters, we can get an infinite loop. -Consider - work item: a ~ b - inert item: b ~ c -We canonicalise the work-item to (a ~ c). If we then swap it before -adding to the inert set, we'll add (c ~ a), and therefore kick out the -inert guy, so we get - new work item: b ~ c - inert item: c ~ a -And now the cycle just repeats - -Historical Note [Eliminate younger unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a choice of unifying - alpha := beta or beta := alpha -we try, if possible, to eliminate the "younger" one, as determined -by `ltUnique`. Reason: the younger one is less likely to appear free in -an existing inert constraint, and hence we are less likely to be forced -into kicking out and rewriting inert constraints. - -This is a performance optimisation only. It turns out to fix -#14723 all by itself, but clearly not reliably so! - -It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). -But, to my surprise, it didn't seem to make any significant difference -to the compiler's performance, so I didn't take it any further. Still -it seemed too nice to discard altogether, so I'm leaving these -notes. SLPJ Jan 18. - -Note [Prevent unification with type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prevent unification with type families because of an uneasy compromise. -It's perfectly sound to unify with type families, and it even improves the -error messages in the testsuite. It also modestly improves performance, at -least in some cases. But it's disastrous for test case perf/compiler/T3064. -Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. -What do we do? Do we reduce F? Or do we use the given? Hard to know what's -best. GHC reduces. This is a disaster for T3064, where the type's size -spirals out of control during reduction. If we prevent -unification with type families, then the solver happens to use the equality -before expanding the type family. - -It would be lovely in the future to revisit this problem and remove this -extra, unnecessary check. But we retain it for now as it seems to work -better in practice. - -Revisited in Nov '20, along with removing flattening variables. Problem -is still present, and the solution is still the same. - -Note [Type synonyms and the occur check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking we try to update a variable with type synonyms not -expanded, which improves later error messages, unless looking -inside a type synonym may help resolve a spurious occurs check -error. Consider: - type A a = () - - f :: (A a -> a -> ()) -> () - f = \ _ -> () - - x :: () - x = f (\ x p -> p x) - -We will eventually get a constraint of the form t ~ A t. The ok function above will -properly expand the type (A t) to just (), which is ok to be unified with t. If we had -unified with the original type A t, we would lead the type checker into an infinite loop. - -Hence, if the occurs check fails for a type synonym application, then (and *only* then), -the ok function expands the synonym to detect opportunities for occurs check success using -the underlying definition of the type synonym. - -The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact, -function @occ_check_ok@. - -Note [Non-TcTyVars in GHC.Tc.Utils.Unify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because the same code is now shared between unifying types and unifying -kinds, we sometimes will see proper TyVars floating around the unifier. -Example (from test case polykinds/PolyKinds12): - - type family Apply (f :: k1 -> k2) (x :: k1) :: k2 - type instance Apply g y = g y - -When checking the instance declaration, we first *kind-check* the LHS -and RHS, discovering that the instance really should be - - type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y - -During this kind-checking, all the tyvars will be TcTyVars. Then, however, -as a second pass, we desugar the RHS (which is done in functions prefixed -with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper -TyVars, not TcTyVars, get some kind unification must happen. - -Thus, we always check if a TyVar is a TcTyVar before asking if it's a -meta-tyvar. - -This used to not be necessary for type-checking (that is, before * :: *) -because expressions get desugared via an algorithm separate from -type-checking (with wrappers, etc.). Types get desugared very differently, -causing this wibble in behavior seen here. --} - --- | Breaks apart a function kind into its pieces. -matchExpectedFunKind - :: TypedThing -- ^ type, only for errors - -> Arity -- ^ n: number of desired arrows - -> TcKind -- ^ fun_kind - -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) - -matchExpectedFunKind hs_ty n k = go n k - where - go 0 k = return (mkNomReflCo k) - - go n k | Just k' <- coreView k = go n k' - - go n k@(TyVarTy kvar) - | isMetaTyVar kvar - = do { maybe_kind <- readMetaTyVar kvar - ; case maybe_kind of - Indirect fun_kind -> go n fun_kind - Flexi -> defer n k } - - go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) - | isVisibleFunArg af - = do { co <- go (n-1) res - ; return (mkNakedFunCo1 Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } - - go n other - = defer n other - - defer n k - = do { arg_kinds <- newMetaKindVars n - ; res_kind <- newMetaKindVar - ; let new_fun = mkVisFunTysMany arg_kinds res_kind - origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun - , uo_thing = Just hs_ty - , uo_visible = True - } - ; uType KindLevel origin k new_fun } - -{- ********************************************************************* -* * - Equality invariant checking -* * -********************************************************************* -} - - -{- Note [Checking for foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unless we have -XImpredicativeTypes (which is a totally unsupported -feature), we do not want to unify - alpha ~ (forall a. a->a) -> Int -So we look for foralls hidden inside the type, and it's convenient -to do that at the same time as the occurs check (which looks for -occurrences of alpha). - -However, it's not just a question of looking for foralls /anywhere/! -Consider - (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) -This is legal; e.g. dependent/should_compile/T11635. - -We don't want to reject it because of the forall in beta's kind, but -(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type) -we do need to look in beta's kind. So we carry a flag saying if a -'forall' is OK, and switch the flag on when stepping inside a kind. - -Why is it OK? Why does it not count as impredicative polymorphism? -The reason foralls are bad is because we reply on "seeing" foralls -when doing implicit instantiation. But the forall inside the kind is -fine. We'll generate a kind equality constraint - (forall k. k->*) ~ (forall k. k->*) -to check that the kinds of lhs and rhs are compatible. If alpha's -kind had instead been - (alpha :: kappa) -then this kind equality would rightly complain about unifying kappa -with (forall k. k->*) - --} - ----------------- -{-# NOINLINE checkTyVarEq #-} -- checkTyVarEq becomes big after the `inline` fires -checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult -checkTyVarEq tv ty - = inline checkTypeEq (TyVarLHS tv) ty - -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away - -{-# NOINLINE checkTyFamEq #-} -- checkTyFamEq becomes big after the `inline` fires -checkTyFamEq :: TyCon -- type function - -> [TcType] -- args, exactly saturated - -> TcType -- RHS - -> CheckTyEqResult -- always drops cteTypeFamily -checkTyFamEq fun_tc fun_args ty - = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty - `cterRemoveProblem` cteTypeFamily - -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away - -checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult --- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs --- is a canonical CEqCan. --- --- In particular, this looks for: --- (a) a forall type (forall a. blah) --- (b) a predicate type (c => ty) --- (c) a type family; see Note [Prevent unification with type families] --- (d) an occurrence of the LHS (occurs check) --- --- Note that an occurs-check does not mean "definite error". For example --- type family F a --- type instance F Int = Int --- consider --- b0 ~ F b0 --- This is perfectly reasonable, if we later get b0 ~ Int. But we --- certainly can't unify b0 := F b0 --- --- For (a), (b), and (c) we check only the top level of the type, NOT --- inside the kinds of variables it mentions, and for (d) see --- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. --- --- checkTypeEq is called from --- * checkTyFamEq, checkTyVarEq (which inline it to specialise away the --- case-analysis on 'lhs') --- * checkEqCanLHSFinish, which does not know the form of 'lhs' -checkTypeEq lhs ty - = go ty - where - impredicative = cteProblem cteImpredicative - type_family = cteProblem cteTypeFamily - insoluble_occurs = cteProblem cteInsolubleOccurs - soluble_occurs = cteProblem cteSolubleOccurs - - -- The GHCi runtime debugger does its type-matching with - -- unification variables that can unify with a polytype - -- or a TyCon that would usually be disallowed by bad_tc - -- See Note [RuntimeUnkTv] in GHC.Runtime.Heap.Inspect - ghci_tv - | TyVarLHS tv <- lhs - , MetaTv { mtv_info = RuntimeUnkTv } <- tcTyVarDetails tv - = True - - | otherwise - = False - - go :: TcType -> CheckTyEqResult - go (TyVarTy tv') = go_tv tv' - go (TyConApp tc tys) = go_tc tc tys - go (LitTy {}) = cteOK - go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) - = go w S.<> go a S.<> go r S.<> - if not ghci_tv && isInvisibleFunArg af - then impredicative - else cteOK - go (AppTy fun arg) = go fun S.<> go arg - go (CastTy ty co) = go ty S.<> go_co co - go (CoercionTy co) = go_co co - go (ForAllTy (Bndr tv' _) ty) = (case lhs of - TyVarLHS tv | tv == tv' -> go_occ (tyVarKind tv') S.<> cterClearOccursCheck (go ty) - | otherwise -> go_occ (tyVarKind tv') S.<> go ty - _ -> go ty) - S.<> - if ghci_tv then cteOK else impredicative - - go_tv :: TcTyVar -> CheckTyEqResult - -- this slightly peculiar way of defining this means - -- we don't have to evaluate this `case` at every variable - -- occurrence - go_tv = case lhs of - TyVarLHS tv -> \ tv' -> go_occ (tyVarKind tv') S.<> - if tv == tv' then insoluble_occurs else cteOK - TyFamLHS {} -> \ _tv' -> cteOK - -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type - - -- For kinds, we only do an occurs check; we do not worry - -- about type families or foralls - -- See Note [Checking for foralls] - go_occ k = cterFromKind $ go k - - go_tc :: TyCon -> [TcType] -> CheckTyEqResult - -- this slightly peculiar way of defining this means - -- we don't have to evaluate this `case` at every tyconapp - go_tc = case lhs of - TyVarLHS {} -> \ tc tys -> check_tc tc S.<> go_tc_args tc tys - TyFamLHS fam_tc fam_args -> \ tc tys -> - if tcEqTyConApps fam_tc fam_args tc tys - then insoluble_occurs - else check_tc tc S.<> go_tc_args tc tys - - -- just look at arguments, not the tycon itself - go_tc_args :: TyCon -> [TcType] -> CheckTyEqResult - go_tc_args tc tys | isGenerativeTyCon tc Nominal = foldMap go tys - | otherwise - = let (tf_args, non_tf_args) = splitAt (tyConArity tc) tys in - cterSetOccursCheckSoluble (foldMap go tf_args) S.<> foldMap go non_tf_args - - -- no bother about impredicativity in coercions, as they're - -- inferred - go_co co | TyVarLHS tv <- lhs - , tv `elemVarSet` tyCoVarsOfCo co - = soluble_occurs - - -- Don't check coercions for type families; see commentary at top of function - | otherwise - = cteOK - - check_tc :: TyCon -> CheckTyEqResult - check_tc - | ghci_tv = \ _tc -> cteOK - | otherwise = \ tc -> (if isTauTyCon tc then cteOK else impredicative) S.<> - (if isFamFreeTyCon tc then cteOK else type_family) +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- | Type subsumption and unification +module GHC.Tc.Utils.Unify ( + -- Full-blown subsumption + tcWrapResult, tcWrapResultO, tcWrapResultMono, + tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType, + tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, + tcSubTypeAmbiguity, tcSubMult, + checkConstraints, checkTvConstraints, + buildImplicationFor, buildTvImplication, emitResidualTvConstraint, + + -- Various unifications + unifyType, unifyKind, unifyInvisibleType, unifyExpectedType, + unifyTypeAndEmit, promoteTcType, + swapOverTyVars, touchabilityAndShapeTest, + UnifyEnv(..), updUEnvLoc, setUEnvRole, + uType, + + -------------------------------- + -- Holes + tcInfer, + matchExpectedListTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchExpectedFunKind, + matchActualFunTySigma, matchActualFunTysRho, + + checkTyEqRhs, recurseIntoTyConApp, + PuResult(..), failCheckWith, okCheckRefl, mapCheck, + TyEqFlags(..), TyEqFamApp(..), AreUnifying(..), LevelCheck(..), FamAppBreaker, + famAppArgFlags, simpleUnifyCheck, checkPromoteFreeVars, + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, hasFixedRuntimeRep_syntactic ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Zonk.TcType + +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs( isInjectiveInType ) +import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} ) +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity +import GHC.Core.Reduction + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Types.Unique.Set (nonDetEltsUniqSet) + +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain + +import GHC.Driver.DynFlags +import GHC.Data.Bag +import GHC.Data.FastString( fsLit ) + +import Control.Monad +import Data.Monoid as DM ( Any(..) ) +import qualified Data.Semigroup as S ( (<>) ) + +{- ********************************************************************* +* * + matchActualFunTys +* * +********************************************************************* -} + +-- | 'matchActualFunTySigma' looks for just one function arrow, +-- returning an uninstantiated sigma-type. +-- +-- Invariant: the returned argument type has a syntactically fixed +-- RuntimeRep in the sense of Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- +-- See Note [Return arguments with a fixed RuntimeRep]. +matchActualFunTySigma + :: ExpectedFunTyOrigin + -- ^ See Note [Herald for matchExpectedFunTys] + -> Maybe TypedThing + -- ^ The thing with type TcSigmaType + -> (Arity, [Scaled TcSigmaType]) + -- ^ Total number of value args in the call, and + -- types of values args to which function has + -- been applied already (reversed) + -- (Both are used only for error messages) + -> TcRhoType + -- ^ Type to analyse: a TcRhoType + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) +-- This function takes in a type to analyse (a RhoType) and returns +-- an argument type and a result type (splitting apart a function arrow). +-- The returned argument type is a SigmaType with a fixed RuntimeRep; +-- as explained in Note [Return arguments with a fixed RuntimeRep]. +-- +-- See Note [matchActualFunTy error handling] for the first three arguments + +-- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty +-- then wrap :: fun_ty ~> (arg_ty -> res_ty) +-- and NB: res_ty is an (uninstantiated) SigmaType + +matchActualFunTySigma herald mb_thing err_info fun_ty + = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $ + go fun_ty + where + -- Does not allocate unnecessary meta variables: if the input already is + -- a function, we just take it apart. Not only is this efficient, + -- it's important for higher rank: the argument might be of form + -- (forall a. ty) -> other + -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd + -- hide the forall inside a meta-variable + go :: TcRhoType -- The type we're processing, perhaps after + -- expanding type synonyms + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) + go ty | Just ty' <- coreView ty = go ty' + + go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ + do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty + ; return (idHsWrapper, Scaled w arg_ty, res_ty) } + + go ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go ty' + Flexi -> defer ty } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + go ty = addErrCtxtM (mk_ctxt ty) (defer ty) + + ------------ + defer fun_ty + = do { arg_ty <- newOpenFlexiTyVarTy + ; res_ty <- newOpenFlexiTyVarTy + ; mult <- newFlexiTyVarTy multiplicityTy + ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty + ; co <- unifyType mb_thing fun_ty unif_fun_ty + ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty + ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } + + ------------ + mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) + mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far) + res_ty n_val_args_in_call + (n_val_args_in_call, arg_tys_so_far) = err_info + +{- Note [matchActualFunTy error handling] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchActualFunTySigma is made much more complicated by the +desire to produce good error messages. Consider the application + f @Int x y +In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments, +and then call matchActualFunTysPart for each individual value +argument. It, in turn, must instantiate any type/dictionary args, +before looking for an arrow type. + +But if it doesn't find an arrow type, it wants to generate a message +like "f is applied to two arguments but its type only has one". +To do that, it needs to know about the args that tcArgs has already +munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; +and hence also the accumulating so_far arg to 'go'. + +This allows us (in mk_ctxt) to construct f's /instantiated/ type, +with just the values-arg arrows, which is what we really want +in the error message. + +Ugh! +-} + +-- | Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application. +-- +-- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Maybe TypedThing -- ^ the thing with type TcSigmaType + -> Arity + -> TcSigmaType + -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) +-- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) +-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) +-- and res_ty is a RhoType +-- NB: the returned type is top-instantiated; it's a RhoType +matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty + = go n_val_args_wanted [] fun_ty + where + go n so_far fun_ty + | not (isRhoTy fun_ty) + = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty + ; (wrap2, arg_tys, res_ty) <- go n so_far rho + ; return (wrap2 <.> wrap1, arg_tys, res_ty) } + + go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) + + go n so_far fun_ty + = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma + herald mb_thing + (n_val_args_wanted, so_far) + fun_ty + ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty + -- NB: arg_ty1 comes from matchActualFunTySigma, so it has + -- a syntactically fixed RuntimeRep as needed to call mkWpFun. + ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } + +{- +************************************************************************ +* * + matchExpected functions +* * +************************************************************************ + +Note [Herald for matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'herald' always looks like: + "The equation(s) for 'f' have" + "The abstraction (\x.e) takes" + "The section (+ x) expects" + "The function 'f' is applied to" + +This is used to construct a message of form + + The abstraction `\Just 1 -> ...' takes two arguments + but its type `Maybe a -> a' has only one + + The equation(s) for `f' have two arguments + but its type `Maybe a -> a' has only one + + The section `(f 3)' requires 'f' to take two arguments + but its type `Int -> Int' has only one + + The function 'f' is applied to two arguments + but its type `Int -> Int' has only one + +When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the +picture, we have a choice in deciding whether to count the type applications as +proper arguments: + + The function 'f' is applied to one visible type argument + and two value arguments + but its type `forall a. a -> a` has only one visible type argument + and one value argument + +Or whether to include the type applications as part of the herald itself: + + The expression 'f @Int' is applied to two arguments + but its type `Int -> Int` has only one + +The latter is easier to implement and is arguably easier to understand, so we +choose to implement that option. + +Note [matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchExpectedFunTys checks that a sigma has the form +of an n-ary function. It passes the decomposed type to the +thing_inside, and returns a wrapper to coerce between the two types + +It's used wherever a language construct must have a functional type, +namely: + A lambda expression + A function definition + An operator section + +This function must be written CPS'd because it needs to fill in the +ExpTypes produced for arguments before it can fill in the ExpType +passed in. + +Note [Return arguments with a fixed RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions + + - matchExpectedFunTys, + - matchActualFunTySigma, + - matchActualFunTysRho, + +peel off argument types, as explained in Note [matchExpectedFunTys]. +It's important that these functions return argument types that have +a fixed runtime representation, otherwise we would be in violation +of the representation-polymorphism invariants of +Note [Representation polymorphism invariants] in GHC.Core. + +This is why all these functions have an additional invariant, +that the argument types they return all have a syntactically fixed RuntimeRep, +in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + +Example: + + Suppose we have + + type F :: Type -> RuntimeRep + type family F a where { F Int = LiftedRep } + + type Dual :: Type -> Type + type family Dual a where + Dual a = a -> () + + f :: forall (a :: TYPE (F Int)). Dual a + f = \ x -> () + + The body of `f` is a lambda abstraction, so we must be able to split off + one argument type from its type. This is handled by `matchExpectedFunTys` + (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that + looks like this: + + f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) + f = \ @(a :: TYPE (F Int)) -> + (\ (x :: (a |> (TYPE F[0]))) -> ()) + `cast` + (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>))) + + Two important transformations took place: + + 1. We inserted casts around the argument type to ensure that it has + a fixed runtime representation, as required by invariant (I1) from + Note [Representation polymorphism invariants] in GHC.Core. + 2. We inserted a cast around the whole lambda to make everything line up + with the type signature. +-} + +-- | Use this function to split off arguments types when you have an +-- \"expected\" type. +-- +-- This function skolemises at each polytype. +-- +-- Invariant: this function only applies the provided function +-- to a list of argument types which all have a syntactically fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchExpectedFunTys :: forall a. + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] + -> UserTypeCtxt + -> Arity + -> ExpRhoType -- Skolemised + -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a) + -> TcM (HsWrapper, a) +-- If matchExpectedFunTys n ty = (wrap, _) +-- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, +-- where [t1, ..., tn], ty_r are passed to the thing_inside +matchExpectedFunTys herald ctx arity orig_ty thing_inside + = case orig_ty of + Check ty -> go [] arity ty + _ -> defer [] arity orig_ty + where + -- Skolemise any foralls /before/ the zero-arg case + -- so that we guarantee to return a rho-type + go acc_arg_tys n ty + | (tvs, theta, _) <- tcSplitSigmaTy ty + , not (null tvs && null theta) + = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> + go acc_arg_tys n ty' + ; return (wrap_gen <.> wrap_res, result) } + + -- No more args; do this /before/ coreView, so + -- that we do not unnecessarily unwrap synonyms + go acc_arg_tys 0 rho_ty + = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty) + ; return (idHsWrapper, result) } + + go acc_arg_tys n ty + | Just ty' <- coreView ty = go acc_arg_tys n ty' + + go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ + do { let arg_pos = 1 + length acc_arg_tys -- for error messages only + ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty + ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) + (n-1) res_ty + ; let wrap_arg = mkWpCastN arg_co + fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty + ; return (fun_wrap, result) } + + go acc_arg_tys n ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go acc_arg_tys n ty' + Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $ + defer acc_arg_tys n (mkCheckExpType ty) + + ------------ + defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) + defer acc_arg_tys n fun_ty + = do { let last_acc_arg_pos = length acc_arg_tys + ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n] + ; res_ty <- newInferExpType + ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty + ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys + ; res_ty <- readExpType res_ty + ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty + ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty + -- Not a good origin at all :-( + ; return (wrap, result) } + + new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR) + new_exp_arg_ty arg_pos -- position for error messages only + = mkScaled <$> newFlexiTyVarTy multiplicityTy + <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) + + ------------ + mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) + mk_ctxt arg_tys res_ty env + = mkFunTysMsg env herald arg_tys' res_ty arity + where + arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $ + reverse arg_tys + -- this is safe b/c we're called from "go" + +mkFunTysMsg :: TidyEnv + -> ExpectedFunTyOrigin + -> [Scaled TcType] -> TcType -> Arity + -> ZonkM (TidyEnv, SDoc) +mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call + = do { (env', fun_rho) <- zonkTidyTcType env $ + mkScaledFunTys arg_tys res_ty + + ; let (all_arg_tys, _) = splitFunTys fun_rho + n_fun_args = length all_arg_tys + + msg | n_val_args_in_call <= n_fun_args -- Enough args, in the end + = text "In the result of a function call" + | otherwise + = hang (full_herald <> comma) + 2 (sep [ text "but its type" <+> quotes (pprType fun_rho) + , if n_fun_args == 0 then text "has none" + else text "has only" <+> speakN n_fun_args]) + + ; return (env', msg) } + where + full_herald = pprExpectedFunTyHerald herald + <+> speakNOf n_val_args_in_call (text "value argument") + +---------------------- +matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) +-- Special case for lists +matchExpectedListTy exp_ty + = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty + ; return (co, elt_ty) } + +--------------------- +matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * + -> TcRhoType -- orig_ty + -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty + [TcSigmaType]) -- Element types, k1 k2 k3 a b c + +-- It's used for wired-in tycons, so we call checkWiredInTyCon +-- Precondition: never called with FunTyCon +-- Precondition: input type :: * +-- Postcondition: (T k1 k2 k3 a b c) is well-kinded + +matchExpectedTyConApp tc orig_ty + = assertPpr (isAlgTyCon tc) (ppr tc) $ + go orig_ty + where + go ty + | Just ty' <- coreView ty + = go ty' + + go ty@(TyConApp tycon args) + | tc == tycon -- Common case + = return (mkNomReflCo ty, args) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- If the common case does not occur, instantiate a template + -- T k1 .. kn t1 .. tm, and unify with the original type + -- Doing it this way ensures that the types we return are + -- kind-compatible with T. For example, suppose we have + -- matchExpectedTyConApp T (f Maybe) + -- where data T a = MkT a + -- Then we don't want to instantiate T's data constructors with + -- (a::*) ~ Maybe + -- because that'll make types that are utterly ill-kinded. + -- This happened in #7368 + defer + = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) + ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) + ; let args = mkTyVarTys arg_tvs + tc_template = mkTyConApp tc args + ; co <- unifyType Nothing tc_template orig_ty + ; return (co, args) } + +---------------------- +matchExpectedAppTy :: TcRhoType -- orig_ty + -> TcM (TcCoercion, -- m a ~N orig_ty + (TcSigmaType, TcSigmaType)) -- Returns m, a +-- If the incoming type is a mutable type variable of kind k, then +-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. + +matchExpectedAppTy orig_ty + = go orig_ty + where + go ty + | Just ty' <- coreView ty = go ty' + + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- Defer splitting by generating an equality constraint + defer + = do { ty1 <- newFlexiTyVarTy kind1 + ; ty2 <- newFlexiTyVarTy kind2 + ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } + + orig_kind = typeKind orig_ty + kind1 = mkVisFunTyMany liftedTypeKind orig_kind + kind2 = liftedTypeKind -- m :: * -> k + -- arg type :: * + +{- ********************************************************************** +* + fillInferResult +* +********************************************************************** -} + +{- Note [inferResultToType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +expTypeToType and inferResultType convert an InferResult to a monotype. +It must be a monotype because if the InferResult isn't already filled in, +we fill it in with a unification variable (hence monotype). So to preserve +order-independence we check for mono-type-ness even if it *is* filled in +already. + +See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and +Note [fillInferResult]. +-} + +-- | Fill an 'InferResult' with the given type. +-- +-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@, +-- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@. +-- +-- This function enforces the following invariants: +-- +-- - Level invariant. +-- The stored type @t2@ is at the same level as given by the +-- 'ir_lvl' field. +-- - FRR invariant. +-- Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed +-- to have a syntactically fixed RuntimeRep, in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +fillInferResult :: TcType -> InferResult -> TcM TcCoercionN +fillInferResult act_res_ty (IR { ir_uniq = u + , ir_lvl = res_lvl + , ir_frr = mb_frr + , ir_ref = ref }) + = do { mb_exp_res_ty <- readTcRef ref + ; case mb_exp_res_ty of + Just exp_res_ty + -- We progressively refine the type stored in 'ref', + -- for example when inferring types across multiple equations. + -- + -- Example: + -- + -- \ x -> case y of { True -> x ; False -> 3 :: Int } + -- + -- When inferring the return type of this function, we will create + -- an 'Infer' 'ExpType', which will first be filled by the type of 'x' + -- after typechecking the first equation, and then filled again with + -- the type 'Int', at which point we want to ensure that we unify + -- the type of 'x' with 'Int'. This is what is happening below when + -- we are "joining" several inferred 'ExpType's. + -> do { traceTc "Joining inferred ExpType" $ + ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty + ; cur_lvl <- getTcLevel + ; unless (cur_lvl `sameDepthAs` res_lvl) $ + ensureMonoType act_res_ty + ; unifyType Nothing act_res_ty exp_res_ty } + Nothing + -> do { traceTc "Filling inferred ExpType" $ + ppr u <+> text ":=" <+> ppr act_res_ty + + -- Enforce the level invariant: ensure the TcLevel of + -- the type we are writing to 'ref' matches 'ir_lvl'. + ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty + + -- Enforce the FRR invariant: ensure the type has a syntactically + -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing'). + ; (frr_co, act_res_ty) <- + case mb_frr of + Nothing -> return (mkNomReflCo act_res_ty, act_res_ty) + Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty + + -- Compose the two coercions. + ; let final_co = prom_co `mkTransCo` frr_co + + ; writeTcRef ref (Just act_res_ty) + + ; return final_co } + } + +{- Note [fillInferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When inferring, we use fillInferResult to "fill in" the hole in InferResult + data InferResult = IR { ir_uniq :: Unique + , ir_lvl :: TcLevel + , ir_ref :: IORef (Maybe TcType) } + +There are two things to worry about: + +1. What if it is under a GADT or existential pattern match? + - GADTs: a unification variable (and Infer's hole is similar) is untouchable + - Existentials: be careful about skolem-escape + +2. What if it is filled in more than once? E.g. multiple branches of a case + case e of + T1 -> e1 + T2 -> e2 + +Our typing rules are: + +* The RHS of a existential or GADT alternative must always be a + monotype, regardless of the number of alternatives. + +* Multiple non-existential/GADT branches can have (the same) + higher rank type (#18412). E.g. this is OK: + case e of + True -> hr + False -> hr + where hr:: (forall a. a->a) -> Int + c.f. Section 7.1 of "Practical type inference for arbitrary-rank types" + We use choice (2) in that Section. + (GHC 8.10 and earlier used choice (1).) + + But note that + case e of + True -> hr + False -> \x -> hr x + will fail, because we still /infer/ both branches, so the \x will get + a (monotype) unification variable, which will fail to unify with + (forall a. a->a) + +For (1) we can detect the GADT/existential situation by seeing that +the current TcLevel is greater than that stored in ir_lvl of the Infer +ExpType. We bump the level whenever we go past a GADT/existential match. + +Then, before filling the hole use promoteTcType to promote the type +to the outer ir_lvl. promoteTcType does this + - create a fresh unification variable alpha at level ir_lvl + - emits an equality alpha[ir_lvl] ~ ty + - fills the hole with alpha +That forces the type to be a monotype (since unification variables can +only unify with monotypes); and catches skolem-escapes because the +alpha is untouchable until the equality floats out. + +For (2), we simply look to see if the hole is filled already. + - if not, we promote (as above) and fill the hole + - if it is filled, we simply unify with the type that is + already there + +There is one wrinkle. Suppose we have + case e of + T1 -> e1 :: (forall a. a->a) -> Int + G2 -> e2 +where T1 is not GADT or existential, but G2 is a GADT. Then suppose the +T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. +But now the G2 alternative must not *just* unify with that else we'd risk +allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first +we'd have filled the hole with a unification variable, which enforces a +monotype. + +So if we check G2 second, we still want to emit a constraint that restricts +the RHS to be a monotype. This is done by ensureMonoType, and it works +by simply generating a constraint (alpha ~ ty), where alpha is a fresh +unification variable. We discard the evidence. + +-} + + + +{- +************************************************************************ +* * + Subsumption checking +* * +************************************************************************ + +Note [Subsumption checking: tcSubType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the tcSubType calls have the form + tcSubType actual_ty expected_ty +which checks + actual_ty <= expected_ty + +That is, that a value of type actual_ty is acceptable in +a place expecting a value of type expected_ty. I.e. that + + actual ty is more polymorphic than expected_ty + +It returns a wrapper function + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. + +Note [Ambiguity check and deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (forall b. Eq b => a -> a) -> Int + +Does `f` have an ambiguous type? The ambiguity check usually checks +that this definition of f' would typecheck, where f' has the exact same +type as f: + f' :: (forall b. Eq b => a -> a) -> Intp + f' = f + +This will be /rejected/ with DeepSubsumption but /accepted/ with +ShallowSubsumption. On the other hand, this eta-expanded version f'' +would be rejected both ways: + f'' :: (forall b. Eq b => a -> a) -> Intp + f'' x = f x + +This is squishy in the same way as other examples in GHC.Tc.Validity +Note [The squishiness of the ambiguity check] + +The situation in June 2022. Since we have SimpleSubsumption at the moment, +we don't want introduce new breakage if you add -XDeepSubsumption, by +rejecting types as ambiguous that weren't ambiguous before. So, as a +holding decision, we /always/ use SimpleSubsumption for the ambiguity check +(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. +-} + + + +----------------- +-- tcWrapResult needs both un-type-checked (for origins and error messages) +-- and type-checked (for wrapping) expressions +tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr + +tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResultO orig rn_expr expr actual_ty res_ty + = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty + , text "Expected:" <+> ppr res_ty ]) + ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty + ; return (mkHsWrap wrap expr) } + +tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc + -> TcRhoType -- Actual -- a rho-type not a sigma-type + -> ExpRhoType -- Expected + -> TcM (HsExpr GhcTc) +-- A version of tcWrapResult to use when the actual type is a +-- rho-type, so nothing to instantiate; just go straight to unify. +-- It means we don't need to pass in a CtOrigin +tcWrapResultMono rn_expr expr act_ty res_ty + = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $ + do { co <- unifyExpectedType rn_expr act_ty res_ty + ; return (mkHsWrapCo co expr) } + +unifyExpectedType :: HsExpr GhcRn + -> TcRhoType -- Actual -- a rho-type not a sigma-type + -> ExpRhoType -- Expected + -> TcM TcCoercionN +unifyExpectedType rn_expr act_ty exp_ty + = case exp_ty of + Infer inf_res -> fillInferResult act_ty inf_res + Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty + +------------------------ +tcSubTypePat :: CtOrigin -> UserTypeCtxt + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- Used in patterns; polarity is backwards compared +-- to tcSubType +-- If wrap = tc_sub_type_et t1 t2 +-- => wrap :: t1 ~> t2 +tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected + = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected + +tcSubTypePat _ _ (Infer inf_res) ty_expected + = do { co <- fillInferResult ty_expected inf_res + -- In patterns we do not instantatiate + + ; return (mkWpCastN (mkSymCo co)) } + +--------------- +tcSubType :: CtOrigin -> UserTypeCtxt + -> TcSigmaType -- ^ Actual + -> ExpRhoType -- ^ Expected + -> TcM HsWrapper +-- Checks that 'actual' is more polymorphic than 'expected' +tcSubType orig ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) + ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } + +--------------- +tcSubTypeDS :: HsExpr GhcRn + -> TcRhoType -- Actual -- a rho-type not a sigma-type + -> ExpRhoType -- Expected + -> TcM HsWrapper +-- Similar signature to unifyExpectedType; does deep subsumption +-- Only one call site, in GHC.Tc.Gen.App.tcApp +tcSubTypeDS rn_expr act_rho res_ty + = case res_ty of + Check exp_rho -> tc_sub_type_deep (unifyType m_thing) orig + GenSigCtxt act_rho exp_rho + + Infer inf_res -> do { co <- fillInferResult act_rho inf_res + ; return (mkWpCastN co) } + where + orig = exprCtOrigin rn_expr + m_thing = Just (HsExprRnThing rn_expr) + +--------------- +tcSubTypeNC :: CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) + -> TcSigmaType -- ^ Actual type + -> ExpRhoType -- ^ Expected type + -> TcM HsWrapper +tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty + = case res_ty of + Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt + ty_actual ty_expected + + Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual + -- See Note [Instantiation of InferResult] + ; co <- fillInferResult rho inf_res + ; return (mkWpCastN co <.> wrap) } + +--------------- +tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we + -- doing this subtype check? + -> UserTypeCtxt -- where did the expected type arise? + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- External entry point, but no ExpTypes on either side +-- Checks that actual <= expected +-- Returns HsWrapper :: actual ~ expected +tcSubTypeSigma orig ctxt ty_actual ty_expected + = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected + +--------------- +tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- See Note [Ambiguity check and deep subsumption] +tcSubTypeAmbiguity ctxt ty_actual ty_expected + = tc_sub_type_shallow (unifyType Nothing) + (AmbiguityCheckOrigin ctxt) + ctxt ty_actual ty_expected + +--------------- +addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a +addSubTypeCtxt ty_actual ty_expected thing_inside + | isRhoTy ty_actual -- If there is no polymorphism involved, the + , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) + = thing_inside -- gives enough context by itself + | otherwise + = addErrCtxtM mk_msg thing_inside + where + mk_msg tidy_env + = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual + ; ty_expected <- readExpType ty_expected + -- A worry: might not be filled if we're debugging. Ugh. + ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected + ; let msg = vcat [ hang (text "When checking that:") + 4 (ppr ty_actual) + , nest 2 (hang (text "is more polymorphic than:") + 2 (ppr ty_expected)) ] + ; return (tidy_env, msg) } + + +{- Note [Instantiation of InferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now always instantiate before filling in InferResult, so that +the result is a TcRhoType: see #17173 for discussion. + +For example: + +1. Consider + f x = (*) + We want to instantiate the type of (*) before returning, else we + will infer the type + f :: forall {a}. a -> forall b. Num b => b -> b -> b + This is surely confusing for users. + + And worse, the monomorphism restriction won't work properly. The MR is + dealt with in simplifyInfer, and simplifyInfer has no way of + instantiating. This could perhaps be worked around, but it may be + hard to know even when instantiation should happen. + +2. Another reason. Consider + f :: (?x :: Int) => a -> a + g y = let ?x = 3::Int in f + Here want to instantiate f's type so that the ?x::Int constraint + gets discharged by the enclosing implicit-parameter binding. + +3. Suppose one defines plus = (+). If we instantiate lazily, we will + infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism + restriction compels us to infer + plus :: Integer -> Integer -> Integer + (or similar monotype). Indeed, the only way to know whether to apply + the monomorphism restriction at all is to instantiate + +There is one place where we don't want to instantiate eagerly, +namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type +command. See Note [Implementing :type] in GHC.Tc.Module. +-} + +--------------- +tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow + :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify + -> CtOrigin -- Used when instantiating + -> UserTypeCtxt -- Used when skolemising + -> TcSigmaType -- Actual; a sigma-type + -> TcSigmaType -- Expected; also a sigma-type + -> TcM HsWrapper +-- Checks that actual_ty is more polymorphic than expected_ty +-- If wrap = tc_sub_type t1 t2 +-- => wrap :: t1 ~> t2 +-- +-- The "how to unify argument" is always a call to `uType TypeLevel orig`, +-- but with different ways of constructing the CtOrigin `orig` from +-- the argument types and context. + +---------------------- +tc_sub_type unify inst_orig ctxt ty_actual ty_expected + = do { deep_subsumption <- xoptM LangExt.DeepSubsumption + ; if deep_subsumption + then tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected + else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected + } + +---------------------- +tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected + | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] + , definitely_mono_shallow ty_actual + = do { traceTc "tc_sub_type (drop to equality)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; mkWpCastN <$> + unify ty_actual ty_expected } + + | otherwise -- This is the general case + = do { traceTc "tc_sub_type (general case)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + + ; (sk_wrap, inner_wrap) + <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> + do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual + ; cow <- unify rho_a sk_rho + ; return (mkWpCastN cow <.> wrap) } + + ; return (sk_wrap <.> inner_wrap) } + +---------------------- +tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected + | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] + , definitely_mono_deep ty_actual + = do { traceTc "tc_sub_type_deep (drop to equality)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; mkWpCastN <$> + unify ty_actual ty_expected } + + | otherwise -- This is the general case + = do { traceTc "tc_sub_type_deep (general case)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + + ; (sk_wrap, inner_wrap) + <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho -> + -- See Note [Deep subsumption] + tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho + + ; return (sk_wrap <.> inner_wrap) } + +definitely_mono_shallow :: TcType -> Bool +definitely_mono_shallow ty = isRhoTy ty + -- isRhoTy: no top level forall or (=>) + +definitely_mono_deep :: TcType -> Bool +definitely_mono_deep ty + | not (definitely_mono_shallow ty) = False + -- isRhoTy: False means top level forall or (=>) + | Just (_, res) <- tcSplitFunTy_maybe ty = definitely_mono_deep res + -- Top level (->) + | otherwise = True + +definitely_poly :: TcType -> Bool +-- A very conservative test: +-- see Note [Don't skolemise unnecessarily] +definitely_poly ty + | (tvs, theta, tau) <- tcSplitSigmaTy ty + , (tv:_) <- tvs -- At least one tyvar + , null theta -- No constraints; see (DP1) + , tv `isInjectiveInType` tau + -- The tyvar actually occurs (DP2), + -- and occurs in an injective position (DP3). + = True + | otherwise + = False + +{- Note [Don't skolemise unnecessarily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to solve + ty_actual <= ty_expected + (Char->Char) <= (forall a. a->a) +We could skolemise the 'forall a', and then complain +that (Char ~ a) is insoluble; but that's a pretty obscure +error. It's better to say that + (Char->Char) ~ (forall a. a->a) +fails. + +If we prematurely go to equality we'll reject a program we should +accept (e.g. #13752). So the test (which is only to improve error +message) is very conservative: + + * ty_actual is /definitely/ monomorphic: see `definitely_mono` + This definitely_mono test comes in "shallow" and "deep" variants + + * ty_expected is /definitely/ polymorphic: see `definitely_poly` + This definitely_poly test is more subtle than you might think. + Here are three cases where expected_ty looks polymorphic, but + isn't, and where it would be /wrong/ to switch to equality: + + (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) + + (DP2) (Char->Char) <= (forall a. Char -> Char) + + (DP3) (Char->Char) <= (forall a. F [a] Char -> Char) + where type instance F [x] t = t + + +Note [Wrapper returned from tcSubMult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no notion of multiplicity coercion in Core, therefore the wrapper +returned by tcSubMult (and derived functions such as tcCheckUsage and +checkManyPattern) is quite unlike any other wrapper: it checks whether the +coercion produced by the constraint solver is trivial, producing a type error +if it is not. This is implemented via the WpMultCoercion wrapper, as desugared +by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check. + +This wrapper needs to be placed in the term; otherwise, checking of the +eventual coercion won't be triggered during desugaring. But it can be put +anywhere, since it doesn't affect the desugared code. + +Why do we check this in the desugarer? It's a convenient place, since it's +right after all the constraints are solved. We need the constraints to be +solved to check whether they are trivial or not. + +An alternative would be to have a kind of constraint which can +only produce trivial evidence. This would allow such checks to happen +in the constraint solver (#18756). +This would be similar to the existing setup for Concrete, see + Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete + (PHASE 1 in particular). +-} + +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcSubMult origin w_actual w_expected + | Just (w1, w2) <- isMultMul w_actual = + do { w1 <- tcSubMult origin w1 w_expected + ; w2 <- tcSubMult origin w2 w_expected + ; return (w1 <.> w2) } + -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is + -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p + -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating + -- multiplicities] in Multiplicity. +tcSubMult origin w_actual w_expected = + case submult w_actual w_expected of + Submult -> return WpHole + Unknown -> tcEqMult origin w_actual w_expected + +tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcEqMult origin w_actual w_expected = do + { + -- Note that here we do not call to `submult`, so we check + -- for strict equality. + ; coercion <- unifyTypeAndEmit TypeLevel origin w_actual w_expected + ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion } + + +{- ********************************************************************* +* * + Deep subsumption +* * +********************************************************************* -} + +{- Note [Deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The DeepSubsumption extension, documented here + + https://github.com/ghc-proposals/ghc-proposals/pull/511. + +makes a best-efforts attempt implement deep subsumption as it was +prior to the Simplify Subsumption proposal: + + https://github.com/ghc-proposals/ghc-proposals/pull/287 + +The effects are in these main places: + +1. In the subsumption check, tcSubType, we must do deep skolemisation: + see the call to tcDeeplySkolemise in tc_sub_type_deep + +2. In tcPolyExpr we must do deep skolemisation: + see the call to tcDeeplySkolemise in tcSkolemiseExpType + +3. for expression type signatures (e :: ty), and functions with type + signatures (e.g. f :: ty; f = e), we must deeply skolemise the type; + see the call to tcDeeplySkolemise in tcSkolemiseScoped. + +4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result + type. Without deep subsumption, unifyExpectedType would be sufficent. + +In all these cases note that the deep skolemisation must be done /first/. +Consider (1) + (forall a. Int -> a -> a) <= Int -> (forall b. b -> b) +We must skolemise the `forall b` before instantiating the `forall a`. +See also Note [Deep skolemisation]. + +Note that we /always/ use shallow subsumption in the ambiguity check. +See Note [Ambiguity check and deep subsumption]. + +Note [Deep skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +deeplySkolemise decomposes and skolemises a type, returning a type +with all its arrows visible (ie not buried under foralls) + +Examples: + + deeplySkolemise (Int -> forall a. Ord a => blah) + = ( wp, [a], [d:Ord a], Int -> blah ) + where wp = \x:Int. /\a. \(d:Ord a). x + + deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) + where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x + +In general, + if deeplySkolemise ty = (wrap, tvs, evs, rho) + and e :: rho + then wrap e :: ty + and 'wrap' binds tvs, evs + +ToDo: this eta-abstraction plays fast and loose with termination, + because it can introduce extra lambdas. Maybe add a `seq` to + fix this + +Note [Setting the argument context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we are doing the ambiguity check for the (bogus) + f :: (forall a b. C b => a -> a) -> Int + +We'll call + tcSubType ((forall a b. C b => a->a) -> Int ) + ((forall a b. C b => a->a) -> Int ) + +with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing +on the argument type of the (->) -- and at that point we want to switch +to a UserTypeCtxt of GenSigCtxt. Why? + +* Error messages. If we stick with FunSigCtxt we get errors like + * Could not deduce: C b + from the context: C b0 + bound by the type signature for: + f :: forall a b. C b => a->a + But of course f does not have that type signature! + Example tests: T10508, T7220a, Simple14 + +* Implications. We may decide to build an implication for the whole + ambiguity check, but we don't need one for each level within it, + and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. + See Note [When to build an implication] + +Note [Multiplicity in deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + t1 ->{mt} t2 <= s1 ->{ms} s2 + +At the moment we /unify/ ms~mt, via tcEqMult. + +Arguably we should use `tcSubMult`. But then if mt=m0 (a unification +variable) and ms=Many, `tcSubMult` is a no-op (since anything is a +sub-multiplicty of Many). But then `m0` may never get unified with +anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds +Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base +we get this + + "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys + = \xs -> xs ++ ys + +where we eta-expanded that (:). But now foldr expects an argument +with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint +complains. + +The easiest solution was to use tcEqMult in tc_sub_type_ds, and +insist on equality. This is only in the DeepSubsumption code anyway. +-} + +tc_sub_type_ds :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify + -> CtOrigin -- Used when instantiating + -> UserTypeCtxt -- Used when skolemising + -> TcSigmaType -- Actual; a sigma-type + -> TcRhoType -- Expected; deeply skolemised + -> TcM HsWrapper + +-- If wrap = tc_sub_type_ds t1 t2 +-- => wrap :: t1 ~> t2 +-- Here is where the work actually happens! +-- Precondition: ty_expected is deeply skolemised + +tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected + = do { traceTc "tc_sub_type_ds" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; go ty_actual ty_expected } + where + -- NB: 'go' is not recursive, except for doing coreView + go ty_a ty_e | Just ty_a' <- coreView ty_a = go ty_a' ty_e + | Just ty_e' <- coreView ty_e = go ty_a ty_e' + + go (TyVarTy tv_a) ty_e + = do { lookup_res <- isFilledMetaTyVar_maybe tv_a + ; case lookup_res of + Just ty_a' -> + do { traceTc "tc_sub_type_ds following filled meta-tyvar:" + (ppr tv_a <+> text "-->" <+> ppr ty_a') + ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e } + Nothing -> just_unify ty_actual ty_expected } + + go ty_a@(FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) + ty_e@(FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) + | isVisibleFunArg af1, isVisibleFunArg af2 + = if (isTauTy ty_a && isTauTy ty_e) -- Short cut common case to avoid + then just_unify ty_actual ty_expected -- unnecessary eta expansion + else + -- This is where we do the co/contra thing, and generate a WpFun, which in turn + -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption + do { arg_wrap <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg + -- GenSigCtxt: See Note [Setting the argument context] + ; res_wrap <- tc_sub_type_ds unify inst_orig ctxt act_res exp_res + ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult + -- See Note [Multiplicity in deep subsumption] + ; return (mult_wrap <.> + mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) } + -- arg_wrap :: exp_arg ~> act_arg + -- res_wrap :: act-res ~> exp_res + where + given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) + + go ty_a ty_e + | let (tvs, theta, _) = tcSplitSigmaTy ty_a + , not (null tvs && null theta) + = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a + ; body_wrap <- tc_sub_type_ds unify inst_orig ctxt in_rho ty_e + ; return (body_wrap <.> in_wrap) } + + | otherwise -- Revert to unification + = do { -- It's still possible that ty_actual has nested foralls. Instantiate + -- these, as there's no way unification will succeed with them in. + -- See typecheck/should_compile/T11305 for an example of when this + -- is important. The problem is that we're checking something like + -- a -> forall b. b -> b <= alpha beta gamma + -- where we end up with alpha := (->) + (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual + ; unify_wrap <- just_unify rho_a ty_expected + ; return (unify_wrap <.> inst_wrap) } + + just_unify ty_a ty_e = do { cow <- unify ty_a ty_e + ; return (mkWpCastN cow) } + +tcDeeplySkolemise + :: UserTypeCtxt -> TcSigmaType + -> (TcType -> TcM result) + -> TcM (HsWrapper, result) + -- ^ The wrapper has type: spec_ty ~> expected_ty +-- Just like tcTopSkolemise, but calls +-- deeplySkolemise instead of topSkolemise +-- See Note [Deep skolemisation] +tcDeeplySkolemise ctxt expected_ty thing_inside + | isTauTy expected_ty -- Short cut for common case + = do { res <- thing_inside expected_ty + ; return (idHsWrapper, res) } + | otherwise + = do { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise; + -- but skol_info can't be built until we have tv_prs + rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + + ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs) + + ; let skol_tvs = map snd tv_prs + ; (ev_binds, result) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + thing_inside rho_ty + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + +deeplySkolemise :: SkolemInfo -> TcSigmaType + -> TcM ( HsWrapper + , [(Name,TyVar)] -- All skolemised variables + , [EvVar] -- All "given"s + , TcRhoType ) +-- See Note [Deep skolemisation] +deeplySkolemise skol_info ty + = go init_subst ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + = do { let arg_tys' = substScaledTys subst arg_tys + ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' + ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs + ; ev_vars1 <- newEvVars (substTheta subst' theta) + ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' + ; let tv_prs1 = map tyVarName tvs `zip` tvs1 + ; return ( mkWpEta ids1 (mkWpTyLams tvs1 + <.> mkWpEvLams ev_vars1 + <.> wrap) + , tv_prs1 ++ tvs_prs2 + , ev_vars1 ++ ev_vars2 + , mkScaledFunTys arg_tys' rho ) } + + | otherwise + = return (idHsWrapper, [], [], substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +deeplyInstantiate orig ty + = go init_subst ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty + = do { (subst', tvs') <- newMetaTyVarsX subst tvs + ; let arg_tys' = substScaledTys subst' arg_tys + theta' = substTheta subst' theta + ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' + ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' + ; (wrap2, rho2) <- go subst' rho + ; return (mkWpEta ids1 (wrap2 <.> wrap1), + mkScaledFunTys arg_tys' rho2) } + + | otherwise + = do { let ty' = substTy subst ty + ; return (idHsWrapper, ty') } + +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) +-- Looks for a *non-trivial* quantified type, under zero or more function arrows +-- By "non-trivial" we mean either tyvars or constraints are non-empty + +tcDeepSplitSigmaTy_maybe ty + | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- tcSplitSigmaTy ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) + + | otherwise = Nothing + + +{- ********************************************************************* +* * + Generalisation +* * +********************************************************************* -} + +{- Note [Skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~ +tcTopSkolemise takes "expected type" and strip off quantifiers to expose the +type underneath, binding the new skolems for the 'thing_inside' +The returned 'HsWrapper' has type (specific_ty -> expected_ty). + +Note that for a nested type like + forall a. Eq a => forall b. Ord b => blah +we still only build one implication constraint + forall a b. (Eq a, Ord b) => +This is just an optimisation, but it's why we use topSkolemise to +build the pieces from all the layers, before making a single call +to checkConstraints. + +tcSkolemiseScoped is very similar, but differs in two ways: + +* It deals specially with just the outer forall, bringing those type + variables into lexical scope. To my surprise, I found that doing + this unconditionally in tcTopSkolemise (i.e. doing it even if we don't + need to bring the variables into lexical scope, which is harmless) + caused a non-trivial (1%-ish) perf hit on the compiler. + +* It handles deep subumption, wheres tcTopSkolemise never looks under + function arrows. + +* It always calls checkConstraints, even if there are no skolem + variables at all. Reason: there might be nested deferred errors + that must not be allowed to float to top level. + See Note [When to build an implication] below. +-} + +tcTopSkolemise, tcSkolemiseScoped + :: UserTypeCtxt -> TcSigmaType + -> (TcType -> TcM result) + -> TcM (HsWrapper, result) + -- ^ The wrapper has type: spec_ty ~> expected_ty +-- See Note [Skolemisation] for the differences between +-- tcSkolemiseScoped and tcTopSkolemise + +tcSkolemiseScoped ctxt expected_ty thing_inside + = do { deep_subsumption <- xoptM LangExt.DeepSubsumption + ; let skolemise | deep_subsumption = deeplySkolemise + | otherwise = topSkolemise + ; -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + + ; let skol_tvs = map snd tv_prs + ; (ev_binds, res) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + tcExtendNameTyVarEnv tv_prs $ + thing_inside rho_ty + + ; return (wrap <.> mkWpLet ev_binds, res) } + +tcTopSkolemise ctxt expected_ty thing_inside + | isRhoTy expected_ty -- Short cut for common case + = do { res <- thing_inside expected_ty + ; return (idHsWrapper, res) } + | otherwise + = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + + ; let skol_tvs = map snd tv_prs + ; (ev_binds, result) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + thing_inside rho_ty + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + +-- | Variant of 'tcTopSkolemise' that takes an ExpType +tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType + -> (ExpRhoType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemiseExpType _ et@(Infer {}) thing_inside + = (idHsWrapper, ) <$> thing_inside et +tcSkolemiseExpType ctxt (Check ty) thing_inside + = do { deep_subsumption <- xoptM LangExt.DeepSubsumption + ; let skolemise | deep_subsumption = tcDeeplySkolemise + | otherwise = tcTopSkolemise + ; skolemise ctxt ty $ \rho_ty -> + thing_inside (mkCheckExpType rho_ty) } + +checkConstraints :: SkolemInfoAnon + -> [TcTyVar] -- Skolems + -> [EvVar] -- Given + -> TcM result + -> TcM (TcEvBinds, result) + +checkConstraints skol_info skol_tvs given thing_inside + = do { implication_needed <- implicationNeeded skol_info skol_tvs given + + ; if implication_needed + then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted + ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) + ; emitImplications implics + ; return (ev_binds, result) } + + else -- Fast path. We check every function argument with tcCheckPolyExpr, + -- which uses tcTopSkolemise and hence checkConstraints. + -- So this fast path is well-exercised + do { res <- thing_inside + ; return (emptyTcEvBinds, res) } } + +checkTvConstraints :: SkolemInfo + -> [TcTyVar] -- Skolem tyvars + -> TcM result + -> TcM result + +checkTvConstraints skol_info skol_tvs thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted + ; return result } + +emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM () +emitResidualTvConstraint skol_info skol_tvs tclvl wanted + | not (isEmptyWC wanted) || + checkTelescopeSkol skol_info_anon + = -- checkTelescopeSkol: in this case, /always/ emit this implication + -- even if 'wanted' is empty. We need the implication so that we check + -- for a bad telescope. See Note [Skolem escape and forall-types] in + -- GHC.Tc.Gen.HsType + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted + ; emitImplication implic } + + | otherwise -- Empty 'wanted', emit nothing + = return () + where + skol_info_anon = getSkolemInfo skol_info + +buildTvImplication :: SkolemInfoAnon -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM Implication +buildTvImplication skol_info skol_tvs tclvl wanted + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints + -- are solved by filling in coercion holes, not + -- by creating a value-level evidence binding + ; implic <- newImplication + + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given_eqs = NoGivenEqs + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } + + ; checkImplicationInvariants implic' + ; return implic' } + +implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool +-- See Note [When to build an implication] +implicationNeeded skol_info skol_tvs given + | null skol_tvs + , null given + , not (alwaysBuildImplication skol_info) + = -- Empty skolems and givens + do { tc_lvl <- getTcLevel + ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are + then return False -- already inside an implication + else + do { dflags <- getDynFlags -- If any deferral can happen, + -- we must build an implication + ; return (gopt Opt_DeferTypeErrors dflags || + gopt Opt_DeferTypedHoles dflags || + gopt Opt_DeferOutOfScopeVariables dflags) } } + + | otherwise -- Non-empty skolems or givens + = return True -- Definitely need an implication + +alwaysBuildImplication :: SkolemInfoAnon -> Bool +-- See Note [When to build an implication] +alwaysBuildImplication _ = False + +{- Commmented out for now while I figure out about error messages. + See #14185 + +alwaysBuildImplication (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt {} -> True -- RHS of a binding with a signature + _ -> False +alwaysBuildImplication (RuleSkol {}) = True +alwaysBuildImplication (InstSkol {}) = True +alwaysBuildImplication (FamInstSkol {}) = True +alwaysBuildImplication _ = False +-} + +buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] + -> [EvVar] -> WantedConstraints + -> TcM (Bag Implication, TcEvBinds) +buildImplicationFor tclvl skol_info skol_tvs given wanted + | isEmptyWC wanted && null given + -- Optimisation : if there are no wanteds, and no givens + -- don't generate an implication at all. + -- Reason for the (null given): we don't want to lose + -- the "inaccessible alternative" error check + = return (emptyBag, emptyTcEvBinds) + + | otherwise + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + -- Why allow TyVarTvs? Because implicitly declared kind variables in + -- non-CUSK type declarations are TyVarTvs, and we need to bring them + -- into scope as a skolem in an implication. This is OK, though, + -- because TyVarTvs will always remain tyvars, even after unification. + do { ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = skol_info } + ; checkImplicationInvariants implic' + + ; return (unitBag implic', TcEvBinds ev_binds_var) } + +{- Note [When to build an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have some 'skolems' and some 'givens', and we are +considering whether to wrap the constraints in their scope into an +implication. We must /always/ so if either 'skolems' or 'givens' are +non-empty. But what if both are empty? You might think we could +always drop the implication. Other things being equal, the fewer +implications the better. Less clutter and overhead. But we must +take care: + +* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, + we'll make a /term-level/ evidence binding for 'g = error "blah"'. + We must have an EvBindsVar those bindings!, otherwise they end up as + top-level unlifted bindings, which are verboten. This only matters + at top level, so we check for that + See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors. + cf #14149 for an example of what goes wrong. + +* If you have + f :: Int; f = f_blah + g :: Bool; g = g_blah + If we don't build an implication for f or g (no tyvars, no givens), + the constraints for f_blah and g_blah are solved together. And that + can yield /very/ confusing error messages, because we can get + [W] C Int b1 -- from f_blah + [W] C Int b2 -- from g_blan + and fundpes can yield [W] b1 ~ b2, even though the two functions have + literally nothing to do with each other. #14185 is an example. + Building an implication keeps them separate. +-} + +{- +************************************************************************ +* * + Boxy unification +* * +************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. +-} + +unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 + -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) + -> TcM TcCoercionN -- :: ty1 ~# ty2 +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyType thing ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = thing + , uo_visible = True } + +unifyInvisibleType :: TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) + -> TcM TcCoercionN -- :: ty1 ~# ty2 +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyInvisibleType ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = Nothing + , uo_visible = False } -- This is the "invisible" bit + +unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN +-- Like unifyType, but swap expected and actual in error messages +-- This is used when typechecking patterns +unifyTypeET ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped + , uo_expected = ty1 -- NB swapped + , uo_thing = Nothing + , uo_visible = True } + + +unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN +unifyKind mb_thing ty1 ty2 + = unifyTypeAndEmit KindLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = mb_thing + , uo_visible = True } + +unifyTypeAndEmit :: TypeOrKind -> CtOrigin -> TcType -> TcType -> TcM CoercionN +-- Make a ref-cell, unify, emit the collected constraints +unifyTypeAndEmit t_or_k orig ty1 ty2 + = do { ref <- newTcRef emptyBag + ; loc <- getCtLocM orig (Just t_or_k) + ; let env = UE { u_loc = loc, u_role = Nominal + , u_rewriters = emptyRewriterSet -- ToDo: check this + , u_defer = ref, u_unified = Nothing } + + -- The hard work happens here + ; co <- uType env ty1 ty2 + + ; cts <- readTcRef ref + ; unless (null cts) (emitSimples cts) + ; return co } + +{- +%************************************************************************ +%* * + uType and friends +%* * +%************************************************************************ + +Note [The eager unifier] +~~~~~~~~~~~~~~~~~~~~~~~~ +The eager unifier, `uType`, is called by + + * The constraint generator (e.g. in GHC.Tc.Gen.Expr), + via the wrappers `unifyType`, `unifyKind` etc + + * The constraint solver (e.g. in GHC.Tc.Solver.Equality), + via `GHC.Tc.Solver.Monad.wrapUnifierTcS`. + +`uType` runs in the TcM monad, but it carries a UnifyEnv that tells it +what to do when unifying a variable or deferring a constraint. Specifically, + * it collects deferred constraints in `u_defer`, and + * it records which unification variables it has unified in `u_unified` +Then it is up to the wrappers (one for the constraint generator, one for +the constraint solver) to deal with these collected sets. + +Although `uType` runs in the TcM monad for convenience, really it could +operate just with the ability to + * write to the accumulators of deferred constraints + and unification variables in UnifyEnv. + * read and update existing unification variables + * zonk types befire unifying (`zonkTcType` in `uUnfilledVar`, and + `zonkTyCoVarKind` in `uUnfilledVar1` + * create fresh coercion holes (`newCoercionHole`) + * emit tracing info for debugging + * look at the ambient TcLevel: `getTcLevel` +A job for the future. +-} + +data UnifyEnv + = UE { u_role :: Role + , u_loc :: CtLoc + , u_rewriters :: RewriterSet + + -- Deferred constraints + , u_defer :: TcRef (Bag Ct) + + -- Which variables are unified; + -- if Nothing, we don't care + , u_unified :: Maybe (TcRef [TcTyVar]) + } + +setUEnvRole :: UnifyEnv -> Role -> UnifyEnv +setUEnvRole uenv role = uenv { u_role = role } + +updUEnvLoc :: UnifyEnv -> (CtLoc -> CtLoc) -> UnifyEnv +updUEnvLoc uenv@(UE { u_loc = loc }) upd = uenv { u_loc = upd loc } + +mkKindEnv :: UnifyEnv -> TcType -> TcType -> UnifyEnv +-- Modify the UnifyEnv to be right for unifing +-- the kinds of these two types +mkKindEnv env@(UE { u_loc = ctloc }) ty1 ty2 + = env { u_role = Nominal, u_loc = mkKindEqLoc ty1 ty2 ctloc } + +uType, uType_defer + :: UnifyEnv + -> TcType -- ty1 is the *actual* type + -> TcType -- ty2 is the *expected* type + -> TcM CoercionN + +-- It is always safe to defer unification to the main constraint solver +-- See Note [Deferred unification] +uType_defer (UE { u_loc = loc, u_defer = ref + , u_role = role, u_rewriters = rewriters }) + ty1 ty2 -- ty1 is "actual", ty2 is "expected" + = do { let pred_ty = mkPrimEqPredRole role ty1 ty2 + ; hole <- newCoercionHole loc pred_ty + ; let ct = mkNonCanonical $ + CtWanted { ctev_pred = pred_ty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } + co = HoleCo hole + ; updTcRef ref (`snocBag` ct) + -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality + + -- Error trace only + -- NB. do *not* call mkErrInfo unless tracing is on, + -- because it is hugely expensive (#5631) + ; whenDOptM Opt_D_dump_tc_trace $ + do { ctxt <- getErrCtxt + ; doc <- mkErrInfo emptyTidyEnv ctxt + ; traceTc "utype_defer" (vcat [ ppr role + , debugPprType ty1 + , debugPprType ty2 + , doc]) + ; traceTc "utype_defer2" (ppr co) } + + ; return co } + + +-------------- +uType env@(UE { u_role = role }) orig_ty1 orig_ty2 + | Phantom <- role + = do { kind_co <- uType (mkKindEnv env orig_ty1 orig_ty2) + (typeKind orig_ty1) (typeKind orig_ty2) + ; return (mkPhantomCo kind_co orig_ty1 orig_ty2) } + + | otherwise + = do { tclvl <- getTcLevel + ; traceTc "u_tys" $ vcat + [ text "tclvl" <+> ppr tclvl + , sep [ ppr orig_ty1, text "~" <> ppr role, ppr orig_ty2] ] + ; co <- go orig_ty1 orig_ty2 + ; if isReflCo co + then traceTc "u_tys yields no coercion" Outputable.empty + else traceTc "u_tys yields coercion:" (ppr co) + ; return co } + where + go :: TcType -> TcType -> TcM CoercionN + -- The arguments to 'go' are always semantically identical + -- to orig_ty{1,2} except for looking through type synonyms + + -- Unwrap casts before looking for variables. This way, we can easily + -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we + -- didn't do it this way, and then the unification above was deferred. + go (CastTy t1 co1) t2 + = do { co_tys <- uType env t1 t2 + ; return (mkCoherenceLeftCo role t1 co1 co_tys) } + + go t1 (CastTy t2 co2) + = do { co_tys <- uType env t1 t2 + ; return (mkCoherenceRightCo role t2 co2 co_tys) } + + -- Variables; go for uUnfilledVar + -- Note that we pass in *original* (before synonym expansion), + -- so that type variables tend to get filled in with + -- the most informative version of the type + go (TyVarTy tv1) ty2 + = do { lookup_res <- isFilledMetaTyVar_maybe tv1 + ; case lookup_res of + Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) + ; uType env ty1 orig_ty2 } + Nothing -> uUnfilledVar env NotSwapped tv1 ty2 } + + go ty1 (TyVarTy tv2) + = do { lookup_res <- isFilledMetaTyVar_maybe tv2 + ; case lookup_res of + Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) + ; uType env orig_ty1 ty2 } + Nothing -> uUnfilledVar env IsSwapped tv2 ty1 } + + -- See Note [Expanding synonyms during unification] + go ty1@(TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = return $ mkReflCo role ty1 + + -- See Note [Expanding synonyms during unification] + -- + -- Also NB that we recurse to 'go' so that we don't push a + -- new item on the origin stack. As a result if we have + -- type Foo = Int + -- and we try to unify Foo ~ Bool + -- we'll end up saying "can't match Foo with Bool" + -- rather than "can't match "Int with Bool". See #4535. + go ty1 ty2 + | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + -- Functions (t1 -> t2) just check the two parts + go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + | isVisibleFunArg af1 -- Do not attempt (c => t); just defer + , af1 == af2 -- Important! See #21530 + = do { co_w <- uType (env { u_role = funRole role SelMult }) w1 w2 + ; co_l <- uType (env { u_role = funRole role SelArg }) arg1 arg2 + ; co_r <- uType (env { u_role = funRole role SelRes }) res1 res2 + ; return $ mkNakedFunCo role af1 co_w co_l co_r } + + -- Always defer if a type synonym family (type function) + -- is involved. (Data families behave rigidly.) + go ty1@(TyConApp tc1 _) ty2 + | isTypeFamilyTyCon tc1 = defer ty1 ty2 + go ty1 ty2@(TyConApp tc2 _) + | isTypeFamilyTyCon tc2 = defer ty1 ty2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, equalLength tys1 tys2 + , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality + = assertPpr (isGenerativeTyCon tc1 role) (ppr tc1) $ + do { traceTc "go-tycon" (ppr tc1 $$ ppr tys1 $$ ppr tys2 $$ ppr (take 10 (tyConRoleListX role tc1))) + ; cos <- zipWith4M u_tc_arg (tyConVisibilities tc1) -- Infinite + (tyConRoleListX role tc1) -- Infinite + tys1 tys2 + ; return $ mkTyConAppCo role tc1 cos } + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkReflCo role ty + + -- See Note [Care with type applications] + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go ty1@(AppTy s1 t1) ty2@(AppTy s2 t2) + = go_app (isNextArgVisible s1) ty1 s1 t1 ty2 s2 t2 + + go ty1@(AppTy s1 t1) ty2@(TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = assert (not (tyConMustBeSaturated tc2)) $ + go_app (isNextTyConArgVisible tc2 ts2') + ty1 s1 t1 ty2 (TyConApp tc2 ts2') t2' + + go ty1@(TyConApp tc1 ts1) ty2@(AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = assert (not (tyConMustBeSaturated tc1)) $ + go_app (isNextTyConArgVisible tc1 ts1') + ty1 (TyConApp tc1 ts1') t1' ty2 s2 t2 + + go ty1@(CoercionTy co1) ty2@(CoercionTy co2) + = do { kco <- uType (mkKindEnv env ty1 ty2) + (coercionType co1) (coercionType co2) + ; return $ mkProofIrrelCo role kco co1 co2 } + + -- Anything else fails + -- E.g. unifying for-all types, which is relative unusual + go ty1 ty2 = defer ty1 ty2 + + ------------------ + defer ty1 ty2 -- See Note [Check for equality before deferring] + | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) + | otherwise = uType_defer env orig_ty1 orig_ty2 + + + ------------------ + u_tc_arg is_vis role ty1 ty2 + = do { traceTc "u_tc_arg" (ppr role $$ ppr ty1 $$ ppr ty2) + ; uType env_arg ty1 ty2 } + where + env_arg = env { u_loc = adjustCtLoc is_vis False (u_loc env) + , u_role = role } + + ------------------ + -- For AppTy, decompose only nominal equalities + -- See Note [Decomposing AppTy equalities] in GHC.Tc.Solver.Equality + go_app vis ty1 s1 t1 ty2 s2 t2 + | Nominal <- role + = -- Unify arguments t1/t2 before function s1/s2, because + -- the former have smaller kinds, and hence simpler error messages + -- c.f. GHC.Tc.Solver.Equality.can_eq_app + -- Example: test T8603 + do { let env_arg = env { u_loc = adjustCtLoc vis False (u_loc env) } + ; co_t <- uType env_arg t1 t2 + ; co_s <- uType env s1 s2 + ; return $ mkAppCo co_s co_t } + | otherwise + = defer ty1 ty2 + +{- Note [Check for equality before deferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Particularly in ambiguity checks we can get equalities like (ty ~ ty). +If ty involves a type function we may defer, which isn't very sensible. +An egregious example of this was in test T9872a, which has a type signature + Proxy :: Proxy (Solutions Cubes) +Doing the ambiguity check on this signature generates the equality + Solutions Cubes ~ Solutions Cubes +and currently the constraint solver normalises both sides at vast cost. +This little short-cut in 'defer' helps quite a bit. + +Note [Care with type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note: type applications need a bit of care! +They can match FunTy and TyConApp, so use splitAppTy_maybe +NB: we've already dealt with type variables and Notes, +so if one type is an App the other one jolly well better be too + +Note [Mismatched type lists and application decomposition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we find two TyConApps, you might think that the argument lists +are guaranteed equal length. But they aren't. Consider matching + w (T x) ~ Foo (T x y) +We do match (w ~ Foo) first, but in some circumstances we simply create +a deferred constraint; and then go ahead and match (T x ~ T x y). +This came up in #3950. + +So either + (a) either we must check for identical argument kinds + when decomposing applications, + + (b) or we must be prepared for ill-kinded unification sub-problems + +Currently we adopt (b) since it seems more robust -- no need to maintain +a global invariant. + +Note [Expanding synonyms during unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand synonyms during unification, but: + * We expand *after* the variable case so that we tend to unify + variables with un-expanded type synonym. This just makes it + more likely that the inferred types will mention type synonyms + understandable to the user + + * Similarly, we expand *after* the CastTy case, just in case the + CastTy wraps a variable. + + * We expand *before* the TyConApp case. For example, if we have + type Phantom a = Int + and are unifying + Phantom Int ~ Phantom Char + it is *wrong* to unify Int and Char. + + * The problem case immediately above can happen only with arguments + to the tycon. So we check for nullary tycons *before* expanding. + This is particularly helpful when checking (* ~ *), because * is + now a type synonym. + +Note [Deferred unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, +and yet its consistency is undetermined. Previously, there was no way to still +make it consistent. So a mismatch error was issued. + +Now these unifications are deferred until constraint simplification, where type +family instances and given equations may (or may not) establish the consistency. +Deferred unifications are of the form + F ... ~ ... +or x ~ ... +where F is a type function and x is a type variable. +E.g. + id :: x ~ y => x -> y + id e = e + +involves the unification x = y. It is deferred until we bring into account the +context x ~ y to establish that it holds. + +If available, we defer original types (rather than those where closed type +synonyms have already been expanded via tcCoreView). This is, as usual, to +improve error messages. + +************************************************************************ +* * + uUnfilledVar and friends +* * +************************************************************************ + +@uunfilledVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. +-} + +---------- +uUnfilledVar, uUnfilledVar1 + :: UnifyEnv + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2 + -> TcM CoercionN +-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar +-- It might be a skolem, or untouchable, or meta +uUnfilledVar env swapped tv1 ty2 + | Nominal <- u_role env + = do { ty2 <- liftZonkM $ zonkTcType ty2 + -- Zonk to expose things to the occurs check, and so + -- that if ty2 looks like a type variable then it + -- /is/ a type variable + ; uUnfilledVar1 env swapped tv1 ty2 } + + | otherwise -- See Note [Do not unify representational equalities] + -- in GHC.Tc.Solver.Equality + = unSwap swapped (uType_defer env) (mkTyVarTy tv1) ty2 + +uUnfilledVar1 env -- Precondition: u_role==Nominal + swapped + tv1 + ty2 -- ty2 is zonked + | Just tv2 <- getTyVar_maybe ty2 + = go tv2 + + | otherwise + = uUnfilledVar2 env swapped tv1 ty2 + + where + -- 'go' handles the case where both are + -- tyvars so we might want to swap + -- E.g. maybe tv2 is a meta-tyvar and tv1 is not + go tv2 | tv1 == tv2 -- Same type variable => no-op + = return (mkNomReflCo (mkTyVarTy tv1)) + + | swapOverTyVars False tv1 tv2 -- Distinct type variables + -- Swap meta tyvar to the left if poss + = do { tv1 <- liftZonkM $ zonkTyCoVarKind tv1 + -- We must zonk tv1's kind because that might + -- not have happened yet, and it's an invariant of + -- uUnfilledTyVar2 that ty2 is fully zonked + -- Omitting this caused #16902 + ; uUnfilledVar2 env (flipSwap swapped) tv2 (mkTyVarTy tv1) } + + | otherwise + = uUnfilledVar2 env swapped tv1 ty2 + +---------- +uUnfilledVar2 :: UnifyEnv -- Precondition: u_role==Nominal + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2, zonked + -> TcM CoercionN +uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2 + = do { cur_lvl <- getTcLevel + -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles + -- Here we don't know about given equalities here; so we treat + -- /any/ level outside this one as untouchable. Hence cur_lvl. + ; if not (touchabilityAndShapeTest cur_lvl tv1 ty2 + && simpleUnifyCheck False tv1 ty2) + then not_ok_so_defer + else + do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs + + -- Attempt to unify kinds + ; co_k <- uType (mkKindEnv env ty1 ty2) (typeKind ty2) (tyVarKind tv1) + ; traceTc "uUnfilledVar2 ok" $ + vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) + , ppr (isReflCo co_k), ppr co_k ] + + ; if isReflCo co_k + -- Only proceed if the kinds match + -- NB: tv1 should still be unfilled, despite the kind unification + -- because tv1 is not free in ty2' (or, hence, in its kind) + then do { liftZonkM $ writeMetaTyVar tv1 ty2 + ; case u_unified env of + Nothing -> return () + Just uref -> updTcRef uref (tv1 :) + ; return (mkNomReflCo ty2) } -- Unification is always Nominal + + else -- The kinds don't match yet, so defer instead. + do { writeTcRef def_eq_ref def_eqs + -- Since we are discarding co_k, also discard any constraints + -- emitted by kind unification; they are just useless clutter. + -- Do this dicarding by simply restoring the previous state + -- of def_eqs; a bit imperative/yukky but works fine. + ; defer } + }} + where + ty1 = mkTyVarTy tv1 + defer = unSwap swapped (uType_defer env) ty1 ty2 + + not_ok_so_defer = + do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) + -- Occurs check or an untouchable: just defer + -- NB: occurs check isn't necessarily fatal: + -- eg tv1 occurred in type family parameter + ; defer } + +swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool +swapOverTyVars is_given tv1 tv2 + -- See Note [Unification variables on the left] + | not is_given, pri1 == 0, pri2 > 0 = True + | not is_given, pri2 == 0, pri1 > 0 = False + + -- Level comparison: see Note [TyVar/TyVar orientation] + | lvl1 `strictlyDeeperThan` lvl2 = False + | lvl2 `strictlyDeeperThan` lvl1 = True + + -- Priority: see Note [TyVar/TyVar orientation] + | pri1 > pri2 = False + | pri2 > pri1 = True + + -- Names: see Note [TyVar/TyVar orientation] + | isSystemName tv2_name, not (isSystemName tv1_name) = True + + | otherwise = False + + where + lvl1 = tcTyVarLevel tv1 + lvl2 = tcTyVarLevel tv2 + pri1 = lhsPriority tv1 + pri2 = lhsPriority tv2 + tv1_name = Var.varName tv1 + tv2_name = Var.varName tv2 + + +lhsPriority :: TcTyVar -> Int +-- Higher => more important to be on the LHS +-- => more likely to be eliminated +-- See Note [TyVar/TyVar orientation] +lhsPriority tv + = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + RuntimeUnk -> 0 + SkolemTv {} -> 0 + MetaTv { mtv_info = info } -> case info of + CycleBreakerTv -> 0 + TyVarTv -> 1 + ConcreteTv {} -> 2 + TauTv -> 3 + RuntimeUnkTv -> 4 + +{- Note [Unification preconditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Question: given a homogeneous equality (alpha ~# ty), when is it OK to +unify alpha := ty? + +This note only applied to /homogeneous/ equalities, in which both +sides have the same kind. + +There are five reasons not to unify: + +1. (SKOL-ESC) Skolem-escape + Consider the constraint + forall[2] a[2]. alpha[1] ~ Maybe a[2] + If we unify alpha := Maybe a, the skolem 'a' may escape its scope. + The level alpha[1] says that alpha may be used outside this constraint, + where 'a' is not in scope at all. So we must not unify. + + Bottom line: when looking at a constraint alpha[n] := ty, do not unify + if any free variable of 'ty' has level deeper (greater) than n + +2. (UNTOUCHABLE) Untouchable unification variables + Consider the constraint + forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int + There is no (SKOL-ESC) problem with unifying alpha := Int, but it might + not be the principal solution. Perhaps the "right" solution is alpha := b. + We simply can't tell. See "OutsideIn(X): modular type inference with local + assumptions", section 2.2. We say that alpha[1] is "untouchable" inside + this implication. + + Bottom line: at ambient level 'l', when looking at a constraint + alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities + between levels 'n' and 'l'. + + Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)? + Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + +3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs + This precondition looks at the MetaInfo of the unification variable: + + * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a + TyVarTv it can only unify with a type variable, not with a + structured type. So if 'ty' is a structured type, such as (Maybe x), + don't unify. + + * CycleBreakerTv: never unified, except by restoreTyVarCycles. + +4. (CONCRETE) A ConcreteTv can only unify with a concrete type, + by definition. + + That is, if we have `rr[conc] ~ F Int`, we can't unify + `rr` with `F Int`, so we hold off on unifying. + Note however that the equality might get rewritten; for instance + if we can rewrite `F Int` to a concrete type, say `FloatRep`, + then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. + + Note that we can still make progress on unification even if + we can't fully solve an equality, e.g. + + alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ] + + we can fill beta[tau] := beta[conc]. This is why we call + 'makeTypeConcrete' in startSolvingByUnification. + +5. (COERCION-HOLE) Confusing coercion holes + Suppose our equality is + (alpha :: k) ~ (Int |> {co}) + where co :: Type ~ k is an unsolved wanted. Note that this equality + is homogeneous; both sides have kind k. We refrain from unifying here, because + of the coercion hole in the RHS -- see Wrinkle (EIK2) in + Note [Equalities with incompatible kinds] in GHC.Solver.Equality. + +Needless to say, all there are wrinkles: + +* (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free + in 'ty', where beta is a unification variable, and k>n? 'beta' + stands for a monotype, and since it is part of a level-n type + (equal to alpha[n]), we must /promote/ beta to level n. Just make + up a fresh gamma[n], and unify beta[k] := gamma[n]. + +* (TYVAR-TV) Unification variables. Suppose alpha[tyv,n] is a level-n + TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now + consider alpha[tyv,n] ~ Bool. We don't want to unify because that + would break the TyVarTv invariant. + + What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary + TauTv? Again, don't unify, because beta might later be unified + with, say Bool. (If levels permit, we reverse the orientation here; + see Note [TyVar/TyVar orientation].) + +* (UNTOUCHABLE) Untouchability. When considering (alpha[n] ~ ty), how + do we know whether there are any given equalities between level n + and the ambient level? We answer in two ways: + + * In the eager unifier, we only unify if l=n. If not, alpha may be + untouchable, and defer to the constraint solver. This check is + made in GHC.Tc.Utils.uUnifilledVar2, in the guard + isTouchableMetaTyVar. + + * In the constraint solver, we track where Given equalities occur + and use that to guard unification in + GHC.Tc.Utils.Unify.touchabilityAndShapeTest. More details in + Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + + Historical note: in the olden days (pre 2021) the constraint solver + also used to unify only if l=n. Equalities were "floated" out of the + implication in a separate step, so that they would become touchable. + But the float/don't-float question turned out to be very delicate, + as you can see if you look at the long series of Notes associated with + GHC.Tc.Solver.floatEqualities, around Nov 2020. It's much easier + to unify in-place, with no floating. + +Note [TyVar/TyVar orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation] +where the kind equality orientation is important + +Given (a ~ b), should we orient the equality as (a~b) or (b~a)? +This is a surprisingly tricky question! + +The question is answered by swapOverTyVars, which is used + - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 + - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2 + +First note: only swap if you have to! + See Note [Avoid unnecessary swaps] + +So we look for a positive reason to swap, using a three-step test: + +* Level comparison. If 'a' has deeper level than 'b', + put 'a' on the left. See Note [Deeper level on the left] + +* Priority. If the levels are the same, look at what kind of + type variable it is, using 'lhsPriority'. + + Generally speaking we always try to put a MetaTv on the left in + preference to SkolemTv or RuntimeUnkTv, because the MetaTv may be + touchable and can be unified. + + Tie-breaking rules for MetaTvs: + - CycleBreakerTv: This is essentially a stand-in for another type; + it's untouchable and should have the same priority as a skolem: 0. + + - TyVarTv: These can unify only with another tyvar, but we can't unify + a TyVarTv with a TauTv, because then the TyVarTv could (transitively) + get a non-tyvar type. So give these a low priority: 1. + + - ConcreteTv: These are like TauTv, except they can only unify with + a concrete type. So we want to be able to write to them, but not quite + as much as TauTvs: 2. + + - TauTv: This is the common case; we want these on the left so that they + can be written to: 3. + + - RuntimeUnkTv: These aren't really meta-variables used in type inference, + but just a convenience in the implementation of the GHCi debugger. + Eagerly write to these: 4. See Note [RuntimeUnkTv] in + GHC.Runtime.Heap.Inspect. + +* Names. If the level and priority comparisons are all + equal, try to eliminate a TyVar with a System Name in + favour of ones with a Name derived from a user type signature + +* Age. At one point in the past we tried to break any remaining + ties by eliminating the younger type variable, based on their + Uniques. See Note [Eliminate younger unification variables] + (which also explains why we don't do this any more) + +Note [Unification variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of +level, so that the unification variable is on the left. + +* We /don't/ want this for Givens because if we ave + [G] a[2] ~ alpha[1] + [W] Bool ~ a[2] + we want to rewrite the wanted to Bool ~ alpha[1], + so we can float the constraint and solve it. + +* But for Wanteds putting the unification variable on + the left means an easier job when floating, and when + reporting errors -- just fewer cases to consider. + + In particular, we get better skolem-escape messages: + see #18114 + +Note [Deeper level on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The most important thing is that we want to put tyvars with +the deepest level on the left. The reason to do so differs for +Wanteds and Givens, but either way, deepest wins! Simple. + +* Wanteds. Putting the deepest variable on the left maximise the + chances that it's a touchable meta-tyvar which can be solved. + +* Givens. Suppose we have something like + forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] + + If we orient the Given a[2] on the left, we'll rewrite the Wanted to + (beta[1] ~ b[1]), and that can float out of the implication. + Otherwise it can't. By putting the deepest variable on the left + we maximise our changes of eliminating skolem capture. + + See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason + to orient with the deepest skolem on the left. + + IMPORTANT NOTE: this test does a level-number comparison on + skolems, so it's important that skolems have (accurate) level + numbers. + +See #15009 for an further analysis of why "deepest on the left" +is a good plan. + +Note [Avoid unnecessary swaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we swap without actually improving matters, we can get an infinite loop. +Consider + work item: a ~ b + inert item: b ~ c +We canonicalise the work-item to (a ~ c). If we then swap it before +adding to the inert set, we'll add (c ~ a), and therefore kick out the +inert guy, so we get + new work item: b ~ c + inert item: c ~ a +And now the cycle just repeats + +Historical Note [Eliminate younger unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a choice of unifying + alpha := beta or beta := alpha +we try, if possible, to eliminate the "younger" one, as determined +by `ltUnique`. Reason: the younger one is less likely to appear free in +an existing inert constraint, and hence we are less likely to be forced +into kicking out and rewriting inert constraints. + +This is a performance optimisation only. It turns out to fix +#14723 all by itself, but clearly not reliably so! + +It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). +But, to my surprise, it didn't seem to make any significant difference +to the compiler's performance, so I didn't take it any further. Still +it seemed too nice to discard altogether, so I'm leaving these +notes. SLPJ Jan 18. + +Note [Prevent unification with type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prevent unification with type families because of an uneasy compromise. +It's perfectly sound to unify with type families, and it even improves the +error messages in the testsuite. It also modestly improves performance, at +least in some cases. But it's disastrous for test case perf/compiler/T3064. +Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. +What do we do? Do we reduce F? Or do we use the given? Hard to know what's +best. GHC reduces. This is a disaster for T3064, where the type's size +spirals out of control during reduction. If we prevent +unification with type families, then the solver happens to use the equality +before expanding the type family. + +It would be lovely in the future to revisit this problem and remove this +extra, unnecessary check. But we retain it for now as it seems to work +better in practice. + +Revisited in Nov '20, along with removing flattening variables. Problem +is still present, and the solution is still the same. + +Note [Non-TcTyVars in GHC.Tc.Utils.Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because the same code is now shared between unifying types and unifying +kinds, we sometimes will see proper TyVars floating around the unifier. +Example (from test case polykinds/PolyKinds12): + + type family Apply (f :: k1 -> k2) (x :: k1) :: k2 + type instance Apply g y = g y + +When checking the instance declaration, we first *kind-check* the LHS +and RHS, discovering that the instance really should be + + type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y + +During this kind-checking, all the tyvars will be TcTyVars. Then, however, +as a second pass, we desugar the RHS (which is done in functions prefixed +with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper +TyVars, not TcTyVars, get some kind unification must happen. + +Thus, we always check if a TyVar is a TcTyVar before asking if it's a +meta-tyvar. + +This used to not be necessary for type-checking (that is, before * :: *) +because expressions get desugared via an algorithm separate from +type-checking (with wrappers, etc.). Types get desugared very differently, +causing this wibble in behavior seen here. +-} + +-- | Breaks apart a function kind into its pieces. +matchExpectedFunKind + :: TypedThing -- ^ type, only for errors + -> Arity -- ^ n: number of desired arrows + -> TcKind -- ^ fun_kind + -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) + +matchExpectedFunKind hs_ty n k = go n k + where + go 0 k = return (mkNomReflCo k) + + go n k | Just k' <- coreView k = go n k' + + go n k@(TyVarTy kvar) + | isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> go n fun_kind + Flexi -> defer n k } + + go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | isVisibleFunArg af + = do { co <- go (n-1) res + ; return (mkNakedFunCo Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } + + go n other + = defer n other + + defer n k + = do { arg_kinds <- newMetaKindVars n + ; res_kind <- newMetaKindVar + ; let new_fun = mkVisFunTysMany arg_kinds res_kind + origin = TypeEqOrigin { uo_actual = k + , uo_expected = new_fun + , uo_thing = Just hs_ty + , uo_visible = True + } + ; unifyTypeAndEmit KindLevel origin k new_fun } + +{- ********************************************************************* +* * + Checking alpha ~ ty + for the on-the-fly unifier +* * +********************************************************************* -} + +simpleUnifyCheck :: Bool -> TcTyVar -> TcType -> Bool +-- A fast check: True <=> unification is OK +-- If it says 'False' then unification might still be OK, but +-- it'll take more work to do -- use the full checkTypeEq +-- +-- * Always rejects foralls unless lhs_tv is RuntimeUnk +-- (used by GHCi debugger) +-- * Rejects a non-concrete type if lhs_tv is concrete +-- * Rejects type families unless fam_ok=True +-- * Does a level-check for type variables +-- +-- This function is pretty heavily used, so it's optimised not to allocate +simpleUnifyCheck fam_ok lhs_tv rhs + = go rhs + where + !(occ_in_ty, occ_in_co) = mkOccFolders lhs_tv + + lhs_tv_lvl = tcTyVarLevel lhs_tv + lhs_tv_is_concrete = isConcreteTyVar lhs_tv + forall_ok = case tcTyVarDetails lhs_tv of + MetaTv { mtv_info = RuntimeUnkTv } -> True + _ -> False + + go (TyVarTy tv) + | lhs_tv == tv = False + | tcTyVarLevel tv > lhs_tv_lvl = False + | lhs_tv_is_concrete, not (isConcreteTyVar tv) = False + | occ_in_ty $! (tyVarKind tv) = False + | otherwise = True + + go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) + | isInvisibleFunArg af, not forall_ok = False + | otherwise = go w && go a && go r + + go (TyConApp tc tys) + | lhs_tv_is_concrete, not (isConcreteTyCon tc) = False + | not (isTauTyCon tc) = False + | not fam_ok, not (isFamFreeTyCon tc) = False + | otherwise = all go tys + + go (AppTy t1 t2) = go t1 && go t2 + go (ForAllTy (Bndr tv _) ty) + | forall_ok = go (tyVarKind tv) && (tv == lhs_tv || go ty) + | otherwise = False + + go (CastTy ty co) = not (occ_in_co co) && go ty + go (CoercionTy co) = not (occ_in_co co) + go (LitTy {}) = True + + +mkOccFolders :: TcTyVar -> (TcType -> Bool, TcCoercion -> Bool) +-- These functions return True +-- * if lhs_tv occurs (incl deeply, in the kind of variable) +-- * if there is a coercion hole +-- No expansion of type synonyms +mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co) + where + !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet + occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole + , tcf_tycobinder = do_bndr } + + do_tcv is v = Any (not (v `elemVarSet` is) && v == lhs_tv) + `mappend` check_ty (varType v) + + do_bndr is tcv _faf = extendVarSet is tcv + do_hole _is _hole = DM.Any True -- Reject coercion holes + +{- ********************************************************************* +* * + Equality invariant checking +* * +********************************************************************* -} + + +{- Note [Checking for foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never want to unify + alpha ~ (forall a. a->a) -> Int +So we look for foralls hidden inside the type, and it's convenient +to do that at the same time as the occurs check (which looks for +occurrences of alpha). + +However, it's not just a question of looking for foralls /anywhere/! +Consider + (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) +This is legal; e.g. dependent/should_compile/T11635. + +We don't want to reject it because of the forall in beta's kind, but +(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type) +we do need to look in beta's kind. So we carry a flag saying if a +'forall' is OK, and switch the flag on when stepping inside a kind. + +Why is it OK? Why does it not count as impredicative polymorphism? +The reason foralls are bad is because we reply on "seeing" foralls +when doing implicit instantiation. But the forall inside the kind is +fine. We'll generate a kind equality constraint + (forall k. k->*) ~ (forall k. k->*) +to check that the kinds of lhs and rhs are compatible. If alpha's +kind had instead been + (alpha :: kappa) +then this kind equality would rightly complain about unifying kappa +with (forall k. k->*) + +Note [Forgetful synonyms in checkTyConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type S a b = b -- Forgets 'a' + + [W] alpha[2] ~ Maybe (S beta[4] gamma[2]) + +We don't want to promote beta to level 2; rather, we should +expand the synonym. (Currently, in checkTypeEqRhs promotion +is irrevocable, by side effect.) + +To avoid this risk we eagerly expand forgetful synonyms. +This also means we won't get an occurs check in + a ~ Maybe (S a b) + +The annoyance is that we might expand the synonym unnecessarily, +something we generally try to avoid. But for now, this seems +simple. + +In a forgetful case like a ~ Maybe (S a b), `checkTyEqRhs` returns +a Reduction that looks + Reduction { reductionCoercion = Refl + , reductionReducedType = Maybe b } +We must jolly well use that reductionReduced type, even though the +reductionCoercion is Refl. See `canEqCanLHSFinish_no_unification`. +-} + +data PuResult a b = PuFail CheckTyEqResult + | PuOK (Bag a) b + +instance Functor (PuResult a) where + fmap _ (PuFail prob) = PuFail prob + fmap f (PuOK cts x) = PuOK cts (f x) + +instance Applicative (PuResult a) where + pure x = PuOK emptyBag x + PuFail p1 <*> PuFail p2 = PuFail (p1 S.<> p2) + PuFail p1 <*> PuOK {} = PuFail p1 + PuOK {} <*> PuFail p2 = PuFail p2 + PuOK c1 f <*> PuOK c2 x = PuOK (c1 `unionBags` c2) (f x) + +instance (Outputable a, Outputable b) => Outputable (PuResult a b) where + ppr (PuFail prob) = text "PuFail" <+> (ppr prob) + ppr (PuOK cts x) = text "PuOK" <> braces + (vcat [ text "redn:" <+> ppr x + , text "cts:" <+> ppr cts ]) + +pprPur :: PuResult a b -> SDoc +-- For debugging +pprPur (PuFail prob) = text "PuFail:" <> ppr prob +pprPur (PuOK {}) = text "PuOK" + +okCheckRefl :: TcType -> TcM (PuResult a Reduction) +okCheckRefl ty = return (PuOK emptyBag (mkReflRedn Nominal ty)) + +failCheckWith :: CheckTyEqResult -> TcM (PuResult a b) +failCheckWith p = return (PuFail p) + +mapCheck :: (x -> TcM (PuResult a Reduction)) + -> [x] + -> TcM (PuResult a Reductions) +mapCheck f xs + = do { (ress :: [PuResult a Reduction]) <- mapM f xs + ; return (unzipRedns <$> sequenceA ress) } + -- sequenceA :: [PuResult a Reduction] -> PuResult a [Reduction] + -- unzipRedns :: [Reduction] -> Reductions + +----------------------------- +-- | Options describing how to deal with a type equality +-- in the pure unifier. See 'checkTyEqRhs' +data TyEqFlags a + = TEF { tef_foralls :: Bool -- Allow foralls + , tef_lhs :: CanEqLHS -- LHS of the constraint + , tef_unifying :: AreUnifying -- Always NotUnifying if tef_lhs is TyFamLHS + , tef_fam_app :: TyEqFamApp a + , tef_occurs :: CheckTyEqProblem } -- Soluble or insoluble occurs check + +-- | What to do when encountering a type-family application while processing +-- a type equality in the pure unifier. +-- +-- See Note [Family applications in canonical constraints] +data TyEqFamApp a + = TEFA_Fail -- Always fail + | TEFA_Recurse -- Just recurse + | TEFA_Break (FamAppBreaker a) -- Recurse, but replace with cycle breaker if fails, + -- using the FamAppBreaker + +data AreUnifying + = Unifying + MetaInfo -- MetaInfo of the LHS tyvar (which is a meta-tyvar) + TcLevel -- Level of the LHS tyvar + LevelCheck + + | NotUnifying -- Not attempting to unify + +data LevelCheck + = LC_None -- Level check not needed: we should never encounter + -- a tyvar at deeper level than the LHS + + | LC_Check -- Do a level check between the LHS tyvar and the occurrence tyvar + -- Fail if the level check fails + + | LC_Promote -- Do a level check between the LHS tyvar and the occurrence tyvar + -- If the level check fails, and the occurrence is a unification + -- variable, promote it + +instance Outputable (TyEqFlags a) where + ppr (TEF { .. }) = text "TEF" <> braces ( + vcat [ text "tef_foralls =" <+> ppr tef_foralls + , text "tef_lhs =" <+> ppr tef_lhs + , text "tef_unifying =" <+> ppr tef_unifying + , text "tef_fam_app =" <+> ppr tef_fam_app + , text "tef_occurs =" <+> ppr tef_occurs ]) + +instance Outputable (TyEqFamApp a) where + ppr TEFA_Fail = text "TEFA_Fail" + ppr TEFA_Recurse = text "TEFA_Fail" + ppr (TEFA_Break {}) = text "TEFA_Break" + +instance Outputable AreUnifying where + ppr NotUnifying = text "NotUnifying" + ppr (Unifying mi lvl lc) = text "Unifying" <+> + braces (ppr mi <> comma <+> ppr lvl <> comma <+> ppr lc) + +instance Outputable LevelCheck where + ppr LC_None = text "LC_None" + ppr LC_Check = text "LC_Check" + ppr LC_Promote = text "LC_Promote" + +famAppArgFlags :: TyEqFlags a -> TyEqFlags a +-- Adjust the flags when going undter a type family +-- Only the outer family application gets the loop-breaker treatment +-- Ditto tyvar promotion. E.g. +-- [W] alpha[2] ~ Maybe (F beta[3]) +-- Do not promote beta[3]; instead promote (F beta[3]) +famAppArgFlags flags@(TEF { tef_unifying = unifying }) + = flags { tef_fam_app = TEFA_Recurse + , tef_unifying = zap_promotion unifying + , tef_occurs = cteSolubleOccurs } + -- tef_occurs: under a type family, an occurs check is not definitely-insoluble + where + zap_promotion (Unifying info lvl LC_Promote) = Unifying info lvl LC_Check + zap_promotion unifying = unifying + +type FamAppBreaker a = TcType -> TcM (PuResult a Reduction) + -- Given a family-application ty, return a Reduction :: ty ~ cvb + -- where 'cbv' is a fresh loop-breaker tyvar (for Given), or + -- just a fresh TauTv (for Wanted) + +checkTyEqRhs :: forall a. TyEqFlags a -> TcType -> TcM (PuResult a Reduction) +checkTyEqRhs flags ty + = case ty of + LitTy {} -> okCheckRefl ty + TyConApp tc tys -> checkTyConApp flags ty tc tys + TyVarTy tv -> checkTyVar flags tv + -- Don't worry about foralls inside the kind; see Note [Checking for foralls] + -- Nor can we expand synonyms; see Note [Occurrence checking: look inside kinds] + -- in GHC.Core.FVs + + FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r} + | isInvisibleFunArg af -- e.g. Num a => blah + , not (tef_foralls flags) + -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F) + | otherwise + -> do { w_res <- checkTyEqRhs flags w + ; a_res <- checkTyEqRhs flags a + ; r_res <- checkTyEqRhs flags r + ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) } + + AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun + ; arg_res <- checkTyEqRhs flags arg + ; return (mkAppRedn <$> fun_res <*> arg_res) } + + CastTy ty co -> do { ty_res <- checkTyEqRhs flags ty + ; co_res <- checkCo flags co + ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) } + + CoercionTy co -> do { co_res <- checkCo flags co + ; return (mkReflCoRedn Nominal <$> co_res) } + + ForAllTy {} + | tef_foralls flags -> okCheckRefl ty + | otherwise -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F) + + +------------------- +checkCo :: TyEqFlags a -> Coercion -> TcM (PuResult a Coercion) +-- See Note [checkCo] +checkCo (TEF { tef_lhs = TyFamLHS {} }) co + = return (pure co) + +checkCo (TEF { tef_lhs = TyVarLHS lhs_tv + , tef_unifying = unifying + , tef_occurs = occ_prob }) co + -- Check for coercion holes, if unifying + -- See (COERCION-HOLE) in Note [Unification preconditions] + | hasCoercionHoleCo co + = failCheckWith (cteProblem cteCoercionHole) + + -- Occurs check (can promote) + | Unifying _ lhs_tv_lvl LC_Promote <- unifying + = do { reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfCo co) + ; if cterHasNoProblem reason + then return (pure co) + else failCheckWith reason } + + -- Occurs check (no promotion) + | lhs_tv `elemVarSet` tyCoVarsOfCo co + = failCheckWith (cteProblem occ_prob) + + | otherwise + = return (pure co) + +{- Note [checkCo] +~~~~~~~~~~~~~~~~~ +We don't often care about the contents of coercions, so checking +coercions before making an equality constraint may be surprising. +But there are several cases we need to be wary of: + +(1) When we're unifying a variable, we must make sure that the variable + appears nowhere on the RHS -- even in a coercion. Otherwise, we'll + create a loop. + +(2) We must still make sure that no variable in a coercion is at too + high a level. But, when unifying, we can promote any variables we encounter. + +(3) We do not unify variables with a type with a free coercion hole. + See (COERCION-HOLE) in Note [Unification preconditions]. + + +Note [Promotion and level-checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"Promotion" happens when we have this: + + [W] w1: alpha[2] ~ Maybe beta[4] + +Here we must NOT unify alpha := Maybe beta, because beta may turn out +to stand for a type involving some inner skolem. Yikes! +Skolem-escape. So instead we /promote/ beta, like this: + + beta[4] := beta'[2] + [W] w1: alpha[2] ~ Maybe beta'[2] + +Now we can unify alpha := Maybe beta', which might unlock other +constraints. But if some other constraint wants to unify beta with a +nested skolem, it'll get stuck with a skolem-escape error. + +Now consider `w2` where a type family is involved (#22194): + + [W] w2: alpha[2] ~ Maybe (F gamma beta[4]) + +In `w2`, it may or may not be the case that `beta` is level 2; suppose +we later discover gamma := Int, and type instance F Int _ = Int. +So, instead, we promote the entire funcion call: + + [W] w2': alpha[2] ~ Maybe gamma[2] + [W] w3: gamma[2] ~ F gamma beta[4] + +Now we can unify alpha := Maybe gamma, which is a Good Thng. + +Wrinkle (W1) + +There is an important wrinkle: /all this only applies when unifying/. +For example, suppose we have + [G] a[2] ~ Maybe b[4] +where 'a' is a skolem. This Given might arise from a GADT match, and +we can absolutely use it to rewrite locally. In fact we must do so: +that is how we exploit local knowledge about the outer skolem a[2]. +This applies equally for a Wanted [W] a[2] ~ Maybe b[4]. Using it for +local rewriting is fine. (It's not clear to me that it is /useful/, +but it's fine anyway.) + +So we only do the level-check in checkTyVar when /unifying/ not for +skolems (or untouchable unification variables). + +Note [Family applications in canonical constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constraint with a type family application in the RHS needs special care. + +* First, occurs checks. If we have + [G] a ~ Maybe (F (Maybe a)) + [W] alpha ~ Maybe (F (Maybe alpha)) + it looks as if we have an occurs check. But go read + Note [Type equality cycles] in GHC.Tc.Solver.Equality + + The same considerations apply when the LHS is a type family: + [G] G a ~ Maybe (F (Maybe (G a))) + [W] G alpha ~ Maybe (F (Maybe (G alpha))) + +* Second, promotion. If we have (#22194) + [W] alpha[2] ~ Maybe (F beta[4]) + it is wrong to promote beta. Instead we want to split to + [W] alpha[2] ~ Maybe gamma[2] + [W] gamma[2] ~ F beta[4] + See Note [Promotion and level-checking] above. + +* Third, concrete type variables. If we have + [W] alpha[conc] ~ Maybe (F tys) + we want to add an extra variable thus: + [W] alpha[conc] ~ Maybe gamma[conc] + [W] gamma[conc] ~ F tys + Now we can unify alpha, and that might unlock something else. + +In all these cases we want to create a fresh type variable, and +emit a new equality connecting it to the type family application. + +The `tef_fam_app` field of `TypeEqFlags` says what to do at a type +family application in the RHS of the constraint. `TEFA_Fail` and +`TEFA_Recurse` are straightforward. `TEFA_Break` is the clever +one. As you can see in `checkFamApp`, it + * Checks the arguments, but using `famAppArgFlags` to record that + we are now "under" a type-family application. It `tef_fam_app` to + `TEFA_Recurse`. + * If any of the arguments fail (level-check error, occurs check) + use the `FamAppBreaker` to create the extra binding. + +Note that this always cycle-breaks the /outermost/ family application. +If we have [W] alpha ~ Maybe (F (G alpha)) +* We'll use checkFamApp on `(F (G alpha))` +* It will recurse into `(G alpha)` with TEFA_Recurse, but not cycle-break it +* The occurs check will fire when we hit `alpha` +* `checkFamApp` on `(F (G alpha))` will see the failure and invoke + the `FamAppBreaker`. +-} + +------------------- +checkTyConApp :: TyEqFlags a + -> TcType -> TyCon -> [TcType] + -> TcM (PuResult a Reduction) +checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok }) + tc_app tc tys + | isTypeFamilyTyCon tc + , let arity = tyConArity tc + = if tys `lengthIs` arity + then checkFamApp flags tc_app tc tys -- Common case + else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys + fun_app = mkTyConApp tc fun_args + ; fun_res <- checkFamApp flags fun_app tc fun_args + ; extra_res <- mapCheck (checkTyEqRhs flags) extra_args + ; traceTc "Over-sat" (ppr tc <+> ppr tys $$ ppr arity $$ pprPur fun_res $$ pprPur extra_res) + ; return (mkAppRedns <$> fun_res <*> extra_res) } + + | Just ty' <- rewriterView tc_app + -- e.g. S a where type S a = F [a] + -- or type S a = Int + -- See Note [Forgetful synonyms in checkTyConApp] + = checkTyEqRhs flags ty' + + | not (isTauTyCon tc || foralls_ok) + = failCheckWith impredicativeProblem + + | Unifying info _ _ <- unifying + , isConcreteInfo info + , not (isConcreteTyCon tc) + = failCheckWith (cteProblem cteConcrete) + + | otherwise -- Recurse on arguments + = recurseIntoTyConApp flags tc tys + +recurseIntoTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction) +recurseIntoTyConApp flags tc tys + = do { tys_res <- mapCheck (checkTyEqRhs flags) tys + ; return (mkTyConAppRedn Nominal tc <$> tys_res) } + +------------------- +checkFamApp :: TyEqFlags a + -> TcType -> TyCon -> [TcType] -- Saturated family application + -> TcM (PuResult a Reduction) +-- See Note [Family applications in canonical constraints] +checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob + , tef_fam_app = fam_app_flag, tef_lhs = lhs }) + fam_app tc tys + = case fam_app_flag of + TEFA_Fail -> failCheckWith (cteProblem cteTypeFamily) + + _ | TyFamLHS lhs_tc lhs_tys <- lhs + , tcEqTyConApps lhs_tc lhs_tys tc tys -- F ty ~ ...(F ty)... + -> case fam_app_flag of + TEFA_Recurse -> failCheckWith (cteProblem occ_prob) + TEFA_Break breaker -> breaker fam_app + + _ | Unifying lhs_info _ _ <- unifying + , isConcreteInfo lhs_info + -> case fam_app_flag of + TEFA_Recurse -> failCheckWith (cteProblem cteConcrete) + TEFA_Break breaker -> breaker fam_app + + TEFA_Recurse + -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys + ; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags) + ; return (mkTyConAppRedn Nominal tc <$> tys_res) } + + TEFA_Break breaker -- Recurse; and break if there is a problem + -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys + ; case tys_res of + PuOK cts redns -> return (PuOK cts (mkTyConAppRedn Nominal tc redns)) + PuFail {} -> breaker fam_app } + where + arg_flags = famAppArgFlags flags + +------------------- +checkTyVar :: forall a. TyEqFlags a -> TcTyVar -> TcM (PuResult a Reduction) +checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob }) occ_tv + = case lhs of + TyFamLHS {} -> success -- Nothing to do if the LHS is a type-family + TyVarLHS lhs_tv -> check_tv unifying lhs_tv + where + lvl_occ = tcTyVarLevel occ_tv + success = okCheckRefl (mkTyVarTy occ_tv) + + --------------------- + check_tv NotUnifying lhs_tv + = simple_occurs_check lhs_tv + -- We need an occurs-check here, but no level check + -- See Note [Promotion and level-checking] wrinkle (W1) + + check_tv (Unifying info lvl prom) lhs_tv + = do { mb_done <- isFilledMetaTyVar_maybe occ_tv + ; case mb_done of + Just {} -> success + -- Already promoted; job done + -- Example alpha[2] ~ Maybe (beta[4], beta[4]) + -- We promote the first occurrence, and then encounter it + -- a second time; we don't want to re-promote it! + -- Remember, the entire process started with a fully zonked type + + Nothing -> check_unif info lvl prom lhs_tv } + + --------------------- + -- We are in the Unifying branch of AreUnifing + check_unif :: MetaInfo -> TcLevel -> LevelCheck + -> TcTyVar -> TcM (PuResult a Reduction) + check_unif lhs_tv_info lhs_tv_lvl prom lhs_tv + | isConcreteInfo lhs_tv_info + , not (isConcreteTyVar occ_tv) + = if can_make_concrete occ_tv + then promote lhs_tv lhs_tv_info lhs_tv_lvl + else failCheckWith (cteProblem cteConcrete) + + | lvl_occ `strictlyDeeperThan` lhs_tv_lvl + = case prom of + LC_None -> pprPanic "check_unif" (ppr lhs_tv $$ ppr occ_tv) + LC_Check -> failCheckWith (cteProblem cteSkolemEscape) + LC_Promote + | isSkolemTyVar occ_tv -> failCheckWith (cteProblem cteSkolemEscape) + | otherwise -> promote lhs_tv lhs_tv_info lhs_tv_lvl + + | otherwise + = simple_occurs_check lhs_tv + + --------------------- + simple_occurs_check lhs_tv + | lhs_tv == occ_tv || check_kind (tyVarKind occ_tv) + = failCheckWith (cteProblem occ_prob) + | otherwise + = success + where + (check_kind, _) = mkOccFolders lhs_tv + + --------------------- + can_make_concrete occ_tv = case tcTyVarDetails occ_tv of + MetaTv { mtv_info = info } -> case info of + ConcreteTv {} -> True + TauTv {} -> True + _ -> False + _ -> False -- Don't attempt to make other type variables concrete + -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv). + + --------------------- + -- occ_tv is definitely a MetaTyVar + promote lhs_tv lhs_tv_info lhs_tv_lvl + | MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv + = do { let new_info | isConcreteInfo lhs_tv_info = lhs_tv_info + | otherwise = info_occ + new_lvl = lhs_tv_lvl `minTcLevel` lvl_occ + -- c[conc,3] ~ p[tau,2]: want to clone p:=p'[conc,2] + -- c[tau,2] ~ p[tau,3]: want to clone p:=p'[tau,2] + + -- Check the kind of occ_tv + ; reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfType (tyVarKind occ_tv)) + + ; if cterHasNoProblem reason -- Successfully promoted + then do { new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv + ; okCheckRefl new_tv_ty } + else failCheckWith reason } + + | otherwise = pprPanic "promote" (ppr occ_tv) + +------------------------- +checkPromoteFreeVars :: CheckTyEqProblem -- What occurs check problem to report + -> TcTyVar -> TcLevel + -> TyCoVarSet -> TcM CheckTyEqResult +-- Check this set of TyCoVars for +-- (a) occurs check +-- (b) promote if necessary, or report skolem escape +checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl vs + = do { oks <- mapM do_one (nonDetEltsUniqSet vs) + ; return (mconcat oks) } + where + do_one :: TyCoVar -> TcM CheckTyEqResult + do_one v | isCoVar v = return cteOK + | lhs_tv == v = return (cteProblem occ_prob) + | no_promotion = return cteOK + | not (isMetaTyVar v) = return (cteProblem cteSkolemEscape) + | otherwise = promote_one v + where + no_promotion = not (tcTyVarLevel v `strictlyDeeperThan` lhs_tv_lvl) + + -- isCoVar case: coercion variables are not an escape risk + -- If an implication binds a coercion variable, it'll have equalities, + -- so the "intervening given equalities" test above will catch it + -- Coercion holes get filled with coercions, so again no problem. + + promote_one tv = do { _ <- promote_meta_tyvar TauTv lhs_tv_lvl tv + ; return cteOK } + +promote_meta_tyvar :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcType +promote_meta_tyvar info dest_lvl occ_tv + = do { -- Check whether occ_tv is already unified. The rhs-type + -- started zonked, but we may have promoted one of its type + -- variables, and we then encounter it for the second time. + -- But if so, it'll definitely be another already-checked TyVar + mb_filled <- isFilledMetaTyVar_maybe occ_tv + ; case mb_filled of { + Just ty -> return ty ; + Nothing -> + + -- OK, not done already, so clone/promote it + do { new_tv <- cloneMetaTyVarWithInfo info dest_lvl occ_tv + ; liftZonkM $ writeMetaTyVar occ_tv (mkTyVarTy new_tv) + ; traceTc "promoteTyVar" (ppr occ_tv <+> text "-->" <+> ppr new_tv) + ; return (mkTyVarTy new_tv) } } } + + + +------------------------- +touchabilityAndShapeTest :: TcLevel -> TcTyVar -> TcType -> Bool +-- This is the key test for untouchability: +-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify +-- and Note [Solve by unification] in GHC.Tc.Solver.Equality +-- True <=> touchability and shape are OK +touchabilityAndShapeTest given_eq_lvl tv rhs + | MetaTv { mtv_info = info, mtv_tclvl = tv_lvl } <- tcTyVarDetails tv + , checkTopShape info rhs + = tv_lvl `deeperThanOrSame` given_eq_lvl + | otherwise + = False + +------------------------- +-- | checkTopShape checks (TYVAR-TV) +-- Note [Unification preconditions]; returns True if these conditions +-- are satisfied. But see the Note for other preconditions, too. +checkTopShape :: MetaInfo -> TcType -> Bool +checkTopShape info xi + = case info of + TyVarTv -> + case getTyVar_maybe xi of -- Looks through type synonyms + Nothing -> False + Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle + SkolemTv {} -> True + RuntimeUnk -> True + MetaTv { mtv_info = TyVarTv } -> True + _ -> False + CycleBreakerTv -> False -- We never unify these + _ -> True 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 @@ -9,9 +9,9 @@ -- This boot file exists only to tie the knot between --- GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate +-- GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate/GHC.Tc.Utils.TcMType -unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion +unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion +unifyInvisibleType :: TcTauType -> TcTauType -> TcM TcCoercion tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs deleted file mode 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ /dev/null @@ -1,1934 +0,0 @@ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - --} - --- | Specialisations of the @HsSyn@ syntax for the typechecker --- --- This module is an extension of @HsSyn@ syntax, for use in the type checker. -module GHC.Tc.Utils.Zonk ( - -- * Other HsSyn functions - mkHsDictLet, mkHsApp, - mkHsAppTy, mkHsCaseAlt, - tcShortCutLit, shortCutLit, hsOverLitName, - conLikeResTy, - - -- * re-exported from TcMonad - TcId, TcIdSet, - - -- * Zonking - -- | For a description of "zonking", see Note [What is zonking?] - -- in "GHC.Tc.Utils.TcMType" - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, - ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBindersX, zonkTyVarBinderX, - zonkTyBndrs, zonkTyBndrsX, - zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, - zonkTyVarOcc, - zonkCoToCo, - zonkEvBinds, zonkTcEvBinds, - zonkTcMethInfoToMethInfoX, - lookupTyVarX - ) where - -import GHC.Prelude - -import GHC.Platform - -import GHC.Builtin.Types -import GHC.Builtin.Names - -import GHC.Hs - -import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) -import GHC.Tc.Utils.Monad -import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) -import GHC.Tc.Types.Evidence -import GHC.Tc.Errors.Types - -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.ConLike -import GHC.Core.DataCon - -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import GHC.Core.Multiplicity -import GHC.Core -import GHC.Core.Predicate - -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.TypeEnv -import GHC.Types.SourceText -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Unique.FM -import GHC.Types.TyThing -import GHC.Driver.Session( getDynFlags, targetPlatform ) - -import GHC.Data.Maybe -import GHC.Data.Bag - -import Control.Monad -import Data.List ( partition ) -import Control.Arrow ( second ) - -{- ********************************************************************* -* * - Short-cuts for overloaded numeric literals -* * -********************************************************************* -} - --- Overloaded literals. Here mainly because it uses isIntTy etc - -{- Note [Short cut for overloaded literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). -But if we have a list like - [4,2,3,2,4,4,2]::[Int] -we use a lot of compile time and space generating and solving all those Num -constraints, and generating calls to fromInteger etc. Better just to cut to -the chase, and cough up an Int literal. Large collections of literals like this -sometimes appear in source files, so it's quite a worthwhile fix. - -So we try to take advantage of whatever nearby type information we have, -to short-cut the process for built-in types. We can do this in two places; - -* In the typechecker, when we are about to typecheck the literal. -* If that fails, in the desugarer, once we know the final type. --} - -tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) -tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty - | not rebindable - , Just res_ty <- checkingExpType_maybe exp_res_ty - = do { dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - Just expr -> return $ Just $ - lit { ol_ext = OverLitTc False expr res_ty } - Nothing -> return Nothing } - | otherwise - = return Nothing - -shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) -shortCutLit platform val res_ty - = case val of - HsIntegral int_lit -> go_integral int_lit - HsFractional frac_lit -> go_fractional frac_lit - HsIsString s src -> go_string s src - where - go_integral int@(IL src neg i) - | isIntTy res_ty && platformInIntRange platform i - = Just (HsLit noAnn (HsInt noExtField int)) - | isWordTy res_ty && platformInWordRange platform i - = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy res_ty - = Just (HsLit noAnn (HsInteger src i res_ty)) - | otherwise - = go_fractional (integralFractionalLit neg i) - -- The 'otherwise' case is important - -- Consider (3 :: Float). Syntactically it looks like an IntLit, - -- so we'll call shortCutIntLit, but of course it's a float - -- This can make a big difference for programs with a lot of - -- literals, compiled without -O - - go_fractional f - | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing - where - valueInRange = - case f of - FL { fl_exp = e } -> (-100) <= e && e <= 100 - -- We limit short-cutting Fractional Literals to when their power of 10 - -- is less than 100, which ensures desugaring isn't slow. - - go_string src s - | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) - | otherwise = Nothing - -mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) - ------------------------------- -hsOverLitName :: OverLitVal -> Name --- Get the canonical 'fromX' name for a particular OverLitVal -hsOverLitName (HsIntegral {}) = fromIntegerName -hsOverLitName (HsFractional {}) = fromRationalName -hsOverLitName (HsIsString {}) = fromStringName - -{- -************************************************************************ -* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -* * -************************************************************************ - -The rest of the zonking is done *after* typechecking. -The main zonking pass runs over the bindings - - a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc - b) convert unbound TcTyVar to Void - c) convert each TcId to an Id by zonking its type - -The type variables are converted by binding mutable tyvars to immutable ones -and then zonking as normal. - -The Ids are converted by binding them in the normal Tc envt; that -way we maintain sharing; eg an Id is zonked at its binding site and they -all occurrences of that Id point to the common zonked copy - -It's all pretty boring stuff, because HsSyn is such a large type, and -the environment manipulation is tiresome. --} - --- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. - --- | See Note [The ZonkEnv] --- Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Utils.TcMType". -data ZonkEnv -- See Note [The ZonkEnv] - = ZonkEnv { ze_flexi :: ZonkFlexi - , ze_tv_env :: TyCoVarEnv TyCoVar - , ze_id_env :: IdEnv Id - , ze_meta_tv_env :: TcRef (TyVarEnv Type) } - -{- Note [The ZonkEnv] -~~~~~~~~~~~~~~~~~~~~~ -* ze_flexi :: ZonkFlexi says what to do with a - unification variable that is still un-unified. - See Note [Un-unified unification variables] - -* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site - of a tyvar or covar, we zonk the kind right away and add a mapping - to the env. This prevents re-zonking the kind at every - occurrence. But this is *just* an optimisation. - -* ze_id_env : IdEnv Id promotes sharing among Ids, by making all - occurrences of the Id point to a single zonked copy, built at the - binding site. - - Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. - In a mutually recursive group - rec { f = ...g...; g = ...f... } - we want the occurrence of g to point to the one zonked Id for g, - and the same for f. - - Because it is knot-tied, we must be careful to consult it lazily. - Specifically, zonkIdOcc is not monadic. - -* ze_meta_tv_env: see Note [Sharing when zonking to Type] - - -Notes: - * We must be careful never to put coercion variables (which are Ids, - after all) in the knot-tied ze_id_env, because coercions can - appear in types, and we sometimes inspect a zonked type in this - module. [Question: where, precisely?] - - * In zonkTyVarOcc we consult ze_tv_env in a monadic context, - a second reason that ze_tv_env can't be monadic. - - * An obvious suggestion would be to have one VarEnv Var to - replace both ze_id_env and ze_tv_env, but that doesn't work - because of the knot-tying stuff mentioned above. - -Note [Un-unified unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we do if we find a Flexi unification variable? -There are three possibilities: - -* DefaultFlexi: this is the common case, in situations like - length @alpha ([] @alpha) - It really doesn't matter what type we choose for alpha. But - we must choose a type! We can't leave mutable unification - variables floating around: after typecheck is complete, every - type variable occurrence must have a binding site. - - So we default it to 'Any' of the right kind. - - All this works for both type and kind variables (indeed - the two are the same thing). - -* SkolemiseFlexi: is a special case for the LHS of RULES. - See Note [Zonking the LHS of a RULE] - -* RuntimeUnkFlexi: is a special case for the GHCi debugger. - It's a way to have a variable that is not a mutable - unification variable, but doesn't have a binding site - either. - -* NoFlexi: See Note [Error on unconstrained meta-variables] - in GHC.Tc.Utils.TcMType. This mode will panic on unfilled - meta-variables. --} - -data ZonkFlexi -- See Note [Un-unified unification variables] - = DefaultFlexi -- Default unbound unification variables to Any - | SkolemiseFlexi -- Skolemise unbound unification variables - -- See Note [Zonking the LHS of a RULE] - | RuntimeUnkFlexi -- Used in the GHCi debugger - | NoFlexi -- Panic on unfilled meta-variables - -- See Note [Error on unconstrained meta-variables] - -- in GHC.Tc.Utils.TcMType - -instance Outputable ZonkEnv where - ppr (ZonkEnv { ze_tv_env = tv_env - , ze_id_env = id_env }) - = text "ZE" <+> braces (vcat - [ text "ze_tv_env =" <+> ppr tv_env - , text "ze_id_env =" <+> ppr id_env ]) - --- The EvBinds have to already be zonked, but that's usually the case. -emptyZonkEnv :: TcM ZonkEnv -emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi - -mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv -mkEmptyZonkEnv flexi - = do { mtv_env_ref <- newTcRef emptyVarEnv - ; return (ZonkEnv { ze_flexi = flexi - , ze_tv_env = emptyVarEnv - , ze_id_env = emptyVarEnv - , ze_meta_tv_env = mtv_env_ref }) } - -initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b -initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi - ; thing_inside ze } - --- | Extend the knot-tied environment. -extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids - -- NB: Don't look at the var to decide which env't to put it in. That - -- would end up knot-tying all the env'ts. - = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - -- Given coercion variables will actually end up here. That's OK though: - -- coercion variables are never looked up in the knot-tied env't, so zonking - -- them simply doesn't get optimised. No one gets hurt. An improvement (?) - -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the - -- recursive groups. But perhaps the time it takes to do the analysis is - -- more than the savings. - -extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars - = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] - , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - where - (tycovars, ids) = partition isTyCoVar vars - -extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv -extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id - = ze { ze_id_env = extendVarEnv id_env id id } - -extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv -extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv - = ze { ze_tv_env = extendVarEnv ty_env tv tv } - -setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv -setZonkType ze flexi = ze { ze_flexi = flexi } - -zonkEnvIds :: ZonkEnv -> TypeEnv -zonkEnvIds (ZonkEnv { ze_id_env = id_env}) - = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- immediately by creating a TypeEnv - -zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id -zonkLIdOcc env = fmap (zonkIdOcc env) - -zonkIdOcc :: ZonkEnv -> TcId -> Id --- Ids defined in this module should be in the envt; --- ignore others. (Actually, data constructors are also --- not LocalVars, even when locally defined, but that is fine.) --- (Also foreign-imported things aren't currently in the ZonkEnv; --- that's ok because they don't need zonking.) --- --- Actually, Template Haskell works in 'chunks' of declarations, and --- an earlier chunk won't be in the 'env' that the zonking phase --- carries around. Instead it'll be in the tcg_gbl_env, already fully --- zonked. There's no point in looking it up there (except for error --- checking), and it's not conveniently to hand; hence the simple --- 'orElse' case in the LocalVar branch. --- --- Even without template splices, in module Main, the checking of --- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id - | isLocalVar id = lookupVarEnv id_env id `orElse` - id - | otherwise = id - -zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] -zonkIdOccs env ids = map (zonkIdOcc env) ids - --- zonkIdBndr is used *after* typechecking to get the Id's type --- to its final form. The TyVarEnv give -zonkIdBndr :: ZonkEnv -> TcId -> TcM Id -zonkIdBndr env v - = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) - return (setIdMult (setIdType v ty') w') - -zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] -zonkIdBndrs env ids = mapM (zonkIdBndr env) ids - -zonkTopBndrs :: [TcId] -> TcM [Id] -zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids - -zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc sel lbl) - = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel - -zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) -zonkEvBndrsX = mapAccumLM zonkEvBndrX - -zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) --- Works for dictionaries and coercions -zonkEvBndrX env var - = do { var' <- zonkEvBndr env var - ; return (extendZonkEnv env [var'], var') } - -zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar --- Works for dictionaries and coercions --- Does not extend the ZonkEnv -zonkEvBndr env var - = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var - -{- -zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm -zonkEvVarOcc env v - | isCoVar v - = EvCoercion <$> zonkCoVarOcc env v - | otherwise - = return (EvId $ zonkIdOcc env v) --} - -zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) -zonkCoreBndrX env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', v') } - | otherwise = zonkTyBndrX env v - -zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var]) -zonkCoreBndrsX = mapAccumLM zonkCoreBndrX - -zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs - -zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrsX = mapAccumLM zonkTyBndrX - -zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) --- This guarantees to return a TyVar (not a TcTyVar) --- then we add it to the envt, so all occurrences are replaced --- --- It does not clone: the new TyVar has the sane Name --- as the old one. This important when zonking the --- TyVarBndrs of a TyCon, whose Names may scope. -zonkTyBndrX env tv - = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $ - do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) - -- Internal names tidy up better, for iface files. - ; let tv' = mkTyVar (tyVarName tv) ki - ; return (extendTyZonkEnv env tv', tv') } - -zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX - -zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis - -> TcM (ZonkEnv, VarBndr TyVar vis) --- Takes a TcTyVar and guarantees to return a TyVar -zonkTyVarBinderX env (Bndr tv vis) - = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', Bndr tv' vis) } - -zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) -zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e - -zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e - -zonkTopDecls :: Bag EvBind - -> LHsBinds GhcTc - -> [LRuleDecl GhcTc] -> [LTcSpecPrag] - -> [LForeignDecl GhcTc] - -> TcM (TypeEnv, - Bag EvBind, - LHsBinds GhcTc, - [LForeignDecl GhcTc], - [LTcSpecPrag], - [LRuleDecl GhcTc]) -zonkTopDecls ev_binds binds rules imp_specs fords - = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds - ; (env2, binds') <- zonkRecMonoBinds env1 binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules - ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } - ---------------------------------------------- -zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc - -> TcM (ZonkEnv, HsLocalBinds GhcTc) -zonkLocalBinds env (EmptyLocalBinds x) - = return (env, (EmptyLocalBinds x)) - -zonkLocalBinds _ (HsValBinds _ (ValBinds {})) - = panic "zonkLocalBinds" -- Not in typechecker output - -zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) - = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } - where - go env [] - = return (env, []) - go env ((r,b):bs) - = do { (env1, b') <- zonkRecMonoBinds env b - ; (env2, bs') <- go env1 bs - ; return (env2, (r,b'):bs') } - -zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do - new_binds <- mapM (wrapLocMA zonk_ip_bind) binds - let - env1 = extendIdZonkEnvRec env - [ n | (L _ (IPBind n _ _)) <- new_binds] - (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds - return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) - where - zonk_ip_bind (IPBind dict_id n e) - = do dict_id' <- zonkIdBndr env dict_id - e' <- zonkLExpr env e - return (IPBind dict_id' n e') - ---------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) -zonkRecMonoBinds env binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds - ; return (env1, binds') }) - ---------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc) -zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds - -zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocMA (zonk_bind env) - -zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = (ty, ticks)}) - = do { (_env, new_pat) <- zonkPat env pat -- Env already extended - ; new_grhss <- zonkGRHSs env zonkLExpr grhss - ; new_ty <- zonkTcTypeToTypeX env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss - , pat_ext = (new_ty, ticks) }) } - -zonk_bind env (VarBind { var_ext = x - , var_id = var, var_rhs = expr }) - = do { new_var <- zonkIdBndr env var - ; new_expr <- zonkLExpr env expr - ; return (VarBind { var_ext = x - , var_id = new_var - , var_rhs = new_expr }) } - -zonk_bind env bind@(FunBind { fun_id = L loc var - , fun_matches = ms - , fun_ext = (co_fn, ticks) }) - = do { new_var <- zonkIdBndr env var - ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = L loc new_var - , fun_matches = new_ms - , fun_ext = (new_co_fn, ticks) }) } - -zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs - , abs_ev_binds = ev_binds - , abs_exports = exports - , abs_binds = val_binds - , abs_sig = has_sig })) - = assert ( all isImmutableTyVar tyvars ) $ - do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds - ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendIdZonkEnvRec env2 $ - collectHsBindsBinders CollNoDictBinders new_val_binds - ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds - ; new_exports <- mapM (zonk_export env3) exports - ; return (new_val_binds, new_exports) } - ; return $ XHsBindsLR $ - AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs - , abs_ev_binds = new_ev_binds - , abs_exports = new_exports, abs_binds = new_val_bind - , abs_sig = has_sig } } - where - zonk_val_bind env lbind - | has_sig - , (L loc bind@(FunBind { fun_id = (L mloc mono_id) - , fun_matches = ms - , fun_ext = (co_fn, ticks) })) <- lbind - = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id - -- Specifically /not/ zonkIdBndr; we do not want to - -- complain about a representation-polymorphic binder - ; (env', new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ L loc $ - bind { fun_id = L mloc new_mono_id - , fun_matches = new_ms - , fun_ext = (new_co_fn, ticks) } } - | otherwise - = zonk_lbind env lbind -- The normal case - - zonk_export :: ZonkEnv -> ABExport -> TcM ABExport - zonk_export env (ABE{ abe_wrap = wrap - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = prags }) - = do new_poly_id <- zonkIdBndr env poly_id - (_, new_wrap) <- zonkCoFn env wrap - new_prags <- zonkSpecPrags env prags - return (ABE{ abe_wrap = new_wrap - , abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id - , abe_prags = new_prags }) - -zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id - , psb_args = details - , psb_def = lpat - , psb_dir = dir })) - = do { id' <- zonkIdBndr env id - ; (env1, lpat') <- zonkPat env lpat - ; details' <- zonkPatSynDetails env1 details - ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return $ PatSynBind x $ - bind { psb_id = L loc id' - , psb_args = details' - , psb_def = lpat' - , psb_dir = dir' } } - -zonkPatSynDetails :: ZonkEnv - -> HsPatSynDetails GhcTc - -> TcM (HsPatSynDetails GhcTc) -zonkPatSynDetails env (PrefixCon _ as) - = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as) -zonkPatSynDetails env (InfixCon a1 a2) - = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) -zonkPatSynDetails env (RecCon flds) - = RecCon <$> mapM (zonkPatSynField env) flds - -zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc) -zonkPatSynField env (RecordPatSynField x y) = - RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y) - -zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc - -> TcM (ZonkEnv, HsPatSynDir GhcTc) -zonkPatSynDir env Unidirectional = return (env, Unidirectional) -zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) -zonkPatSynDir env (ExplicitBidirectional mg) = do - mg' <- zonkMatchGroup env zonkLExpr mg - return (env, ExplicitBidirectional mg') - -zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags -zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps - ; return (SpecPrags ps') } - -zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] -zonkLTcSpecPrags env ps - = mapM zonk_prag ps - where - zonk_prag (L loc (SpecPrag id co_fn inl)) - = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -* * -************************************************************************ --} - -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> MatchGroup GhcTc (LocatedA (body GhcTc)) - -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = L l ms - , mg_ext = MatchGroupTc arg_tys res_ty origin - }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys - ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = L l ms' - , mg_ext = MatchGroupTc arg_tys' res_ty' origin - }) } - -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> LMatch GhcTc (LocatedA (body GhcTc)) - -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) -zonkMatch env zBody (L loc match@(Match { m_pats = pats - , m_grhss = grhss })) - = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } - -------------------------------------------------------------------------- -zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> GRHSs GhcTc (LocatedA (body GhcTc)) - -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) - -zonkGRHSs env zBody (GRHSs x grhss binds) = do - (new_env, new_binds) <- zonkLocalBinds env binds - let - zonk_grhs (GRHS xx guarded rhs) - = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded - new_rhs <- zBody env2 rhs - return (GRHS xx new_guarded new_rhs) - new_grhss <- mapM (wrapLocMA zonk_grhs) grhss - return (GRHSs x new_grhss new_binds) - -{- -************************************************************************ -* * -\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -* * -************************************************************************ --} - -zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc] -zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc) - -zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocMA (zonkExpr env) expr - -zonkExpr env (HsVar x (L l id)) - = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $ - return (HsVar x (L l (zonkIdOcc env id))) - -zonkExpr env (HsUnboundVar her occ) - = do her' <- zonk_her her - return (HsUnboundVar her' occ) - where - zonk_her :: HoleExprRef -> TcM HoleExprRef - zonk_her (HER ref ty u) - = do updMutVarM ref (zonkEvTerm env) - ty' <- zonkTcTypeToTypeX env ty - return (HER ref ty' u) - -zonkExpr env (HsRecSel _ (FieldOcc v occ)) - = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ)) - -zonkExpr _ (HsIPVar x _) = dataConCantHappen x - -zonkExpr _ (HsOverLabel x _ _) = dataConCantHappen x - -zonkExpr env (HsLit x (HsRat e f ty)) - = do new_ty <- zonkTcTypeToTypeX env ty - return (HsLit x (HsRat e f new_ty)) - -zonkExpr _ (HsLit x lit) - = return (HsLit x lit) - -zonkExpr env (HsOverLit x lit) - = do { lit' <- zonkOverLit env lit - ; return (HsOverLit x lit') } - -zonkExpr env (HsLam x matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam x new_matches) - -zonkExpr env (HsLamCase x lc_variant matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase x lc_variant new_matches) - -zonkExpr env (HsApp x e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (HsApp x new_e1 new_e2) - -zonkExpr env (HsAppType ty e at t) - = do new_e <- zonkLExpr env e - new_ty <- zonkTcTypeToTypeX env ty - return (HsAppType new_ty new_e at t) - -- NB: the type is an HsType; can't zonk that! - -zonkExpr env (HsTypedBracket hsb_tc body) - = (\x -> HsTypedBracket x body) <$> zonkBracket env hsb_tc - -zonkExpr env (HsUntypedBracket hsb_tc body) - = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc - -zonkExpr env (HsTypedSplice s _) = runTopSplice s >>= zonkExpr env - -zonkExpr _ e@(HsUntypedSplice _ _) = pprPanic "zonkExpr: HsUntypedSplice" (ppr e) - -zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x - -zonkExpr env (NegApp x expr op) - = do (env', new_op) <- zonkSyntaxExpr env op - new_expr <- zonkLExpr env' expr - return (NegApp x new_expr new_op) - -zonkExpr env (HsPar x lpar e rpar) - = do new_e <- zonkLExpr env e - return (HsPar x lpar new_e rpar) - -zonkExpr _ (SectionL x _ _) = dataConCantHappen x -zonkExpr _ (SectionR x _ _) = dataConCantHappen x -zonkExpr env (ExplicitTuple x tup_args boxed) - = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple x new_tup_args boxed) } - where - zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e - ; return (Present x e') } - zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t - ; return (Missing t') } - - -zonkExpr env (ExplicitSum args alt arity expr) - = do new_args <- mapM (zonkTcTypeToTypeX env) args - new_expr <- zonkLExpr env expr - return (ExplicitSum new_args alt arity new_expr) - -zonkExpr env (HsCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase x new_expr new_ms) - -zonkExpr env (HsIf x e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (HsIf x new_e1 new_e2 new_e3) - -zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocMA zonk_alt) alts - ; ty' <- zonkTcTypeToTypeX env ty - ; return $ HsMultiIf ty' alts' } - where zonk_alt (GRHS x guard expr) - = do { (env', guard') <- zonkStmts env zonkLExpr guard - ; expr' <- zonkLExpr env' expr - ; return $ GRHS x guard' expr' } - -zonkExpr env (HsLet x tkLet binds tkIn expr) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_expr <- zonkLExpr new_env expr - return (HsLet x tkLet new_binds tkIn new_expr) - -zonkExpr env (HsDo ty do_or_lc (L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (L l new_stmts)) - -zonkExpr env (ExplicitList ty exprs) - = do new_ty <- zonkTcTypeToTypeX env ty - new_exprs <- zonkLExprs env exprs - return (ExplicitList new_ty new_exprs) - -zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env con_expr - ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = new_con_expr - , rcon_flds = new_rbinds }) } - -zonkExpr env (ExprWithTySig _ e ty) - = do { e' <- zonkLExpr env e - ; return (ExprWithTySig noExtField e' ty) } - -zonkExpr env (ArithSeq expr wit info) - = do (env1, new_wit) <- zonkWit env wit - new_expr <- zonkExpr env expr - new_info <- zonkArithSeq env1 info - return (ArithSeq new_expr new_wit new_info) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env (HsPragE x prag expr) - = do new_expr <- zonkLExpr env expr - return (HsPragE x prag new_expr) - --- arrow notation extensions -zonkExpr env (HsProc x pat body) - = do { (env1, new_pat) <- zonkPat env pat - ; new_body <- zonkCmdTop env1 body - ; return (HsProc x new_pat new_body) } - --- StaticPointers extension -zonkExpr env (HsStatic (fvs, ty) expr) - = do new_ty <- zonkTcTypeToTypeX env ty - HsStatic (fvs, new_ty) <$> zonkLExpr env expr - -zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) - = do (env1, new_co_fn) <- zonkCoFn env co_fn - new_expr <- zonkExpr env1 expr - return (XExpr (WrapExpr (HsWrap new_co_fn new_expr))) - -zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b))) - = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b - -zonkExpr env (XExpr (ConLikeTc con tvs tys)) - = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys - where - zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty - -- Only the multiplicity can contain unification variables - -- The tvs come straight from the data-con, and so are strictly redundant - -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head - -zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) - -------------------------------------------------------------------------- -{- -Note [Skolems in zonkSyntaxExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider rebindable syntax with something like - - (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' - -The x and y become skolems that are in scope when type-checking the -arguments to the bind. This means that we must extend the ZonkEnv with -these skolems when zonking the arguments to the bind. But the skolems -are different between the two arguments, and so we should theoretically -carry around different environments to use for the different arguments. - -However, this becomes a logistical nightmare, especially in dealing with -the more exotic Stmt forms. So, we simplify by making the critical -assumption that the uniques of the skolems are different. (This assumption -is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.) -Now, we can safely just extend one environment. --} - --- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc - -> TcM (ZonkEnv, SyntaxExpr GhcTc) -zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = do { (env0, res_wrap') <- zonkCoFn env res_wrap - ; expr' <- zonkExpr env0 expr - ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps - ; return (env1, SyntaxExprTc { syn_expr = expr' - , syn_arg_wraps = arg_wraps' - , syn_res_wrap = res_wrap' }) } -zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) - -------------------------------------------------------------------------- - -zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc) -zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc) - -zonkLCmd env cmd = wrapLocMA (zonkCmd env) cmd - -zonkCmd env (XCmd (HsWrap w cmd)) - = do { (env1, w') <- zonkCoFn env w - ; cmd' <- zonkCmd env1 cmd - ; return (XCmd (HsWrap w' cmd')) } -zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) - -zonkCmd env (HsCmdArrForm x op f fixity args) - = do new_op <- zonkLExpr env op - new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm x new_op f fixity new_args) - -zonkCmd env (HsCmdApp x c e) - = do new_c <- zonkLCmd env c - new_e <- zonkLExpr env e - return (HsCmdApp x new_c new_e) - -zonkCmd env (HsCmdLam x matches) - = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam x new_matches) - -zonkCmd env (HsCmdPar x lpar c rpar) - = do new_c <- zonkLCmd env c - return (HsCmdPar x lpar new_c rpar) - -zonkCmd env (HsCmdCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase x new_expr new_ms) - -zonkCmd env (HsCmdLamCase x lc_variant ms) - = do new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdLamCase x lc_variant new_ms) - -zonkCmd env (HsCmdIf x eCond ePred cThen cElse) - = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond - ; new_ePred <- zonkLExpr env1 ePred - ; new_cThen <- zonkLCmd env1 cThen - ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } - -zonkCmd env (HsCmdLet x tkLet binds tkIn cmd) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x tkLet new_binds tkIn new_cmd) - -zonkCmd env (HsCmdDo ty (L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (L l new_stmts)) - - - -zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc) -zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd - -zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) -zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) - = do new_cmd <- zonkLCmd env cmd - new_stack_tys <- zonkTcTypeToTypeX env stack_tys - new_ty <- zonkTcTypeToTypeX env ty - new_ids <- mapSndM (zonkExpr env) ids - - massert (isLiftedTypeKind (typeKind new_stack_tys)) - -- desugarer assumes that this is not representation-polymorphic... - -- but indeed it should always be lifted due to the typing - -- rules for arrows - - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) - -------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) -zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkScaledTcTypeToTypeX env2 t1 - ; return (env2, WpFun c1' c2' t1') } -zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co - ; return (env, WpCast co') } -zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev - ; return (env', WpEvLam ev') } -zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg - ; return (env, WpEvApp arg') } -zonkCoFn env (WpTyLam tv) = assert (isImmutableTyVar tv) $ - do { (env', tv') <- zonkTyBndrX env tv - ; return (env', WpTyLam tv') } -zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } -zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co - ; return (env, WpMultCoercion co') } - -------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } }) - = do { ty' <- zonkTcTypeToTypeX env ty - ; e' <- zonkExpr env e - ; return (lit { ol_ext = x { ol_witness = e' - , ol_type = ty' } }) } - -------------------------------------------------------------------------- -zonkBracket :: ZonkEnv -> HsBracketTc -> TcM HsBracketTc -zonkBracket env (HsBracketTc hsb_thing ty wrap bs) - = do wrap' <- traverse zonkQuoteWrap wrap - bs' <- mapM (zonk_b env) bs - new_ty <- zonkTcTypeToTypeX env ty - return (HsBracketTc hsb_thing new_ty wrap' bs') - where - zonkQuoteWrap (QuoteWrapper ev ty) = do - let ev' = zonkIdOcc env ev - ty' <- zonkTcTypeToTypeX env ty - return (QuoteWrapper ev' ty') - - zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e - return (PendingTcSplice n e') - -------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc) - -zonkArithSeq env (From e) - = do new_e <- zonkLExpr env e - return (From new_e) - -zonkArithSeq env (FromThen e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromThen new_e1 new_e2) - -zonkArithSeq env (FromTo e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromTo new_e1 new_e2) - -zonkArithSeq env (FromThenTo e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (FromThenTo new_e1 new_e2 new_e3) - -------------------------------------------------------------------------- -zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> [LStmt GhcTc (LocatedA (body GhcTc))] - -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))]) -zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndMA (zonkStmt env zBody) s - ; (env2, ss') <- zonkStmts env1 zBody ss - ; return (env2, s' : ss') } - -zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> Stmt GhcTc (LocatedA (body GhcTc)) - -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc))) -zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) - = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs - , b <- bs] - env2 = extendIdZonkEnvRec env1 new_binders - ; new_mzip <- zonkExpr env2 mzip_op - ; return (env2 - , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} - where - zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc - -> TcM (ParStmtBlock GhcTc GhcTc) - zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) - = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts - ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) - new_return) } - -zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs - , recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id - , recS_bind_fn = bind_id - , recS_ext = - RecStmtTc { recS_bind_ty = bind_ty - , recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty} }) - = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id - ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id - ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id - ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty - ; new_rvs <- zonkIdBndrs env3 rvs - ; new_lvs <- zonkIdBndrs env3 lvs - ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty - ; let env4 = extendIdZonkEnvRec env3 new_rvs - ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts - -- Zonk the ret-expressions in an envt that - -- has the polymorphic bindings in the envt - ; new_later_rets <- mapM (zonkExpr env5) later_rets - ; new_rec_rets <- mapM (zonkExpr env5) rec_rets - ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = noLocA new_segStmts - , recS_later_ids = new_lvs - , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id - , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_ext = RecStmtTc - { recS_bind_ty = new_bind_ty - , recS_later_rets = new_later_rets - , recS_rec_rets = new_rec_rets - , recS_ret_ty = new_ret_ty } }) } - -zonkStmt env zBody (BodyStmt ty body then_op guard_op) - = do (env1, new_then_op) <- zonkSyntaxExpr env then_op - (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op - new_body <- zBody env2 body - new_ty <- zonkTcTypeToTypeX env2 ty - return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) - -zonkStmt env zBody (LastStmt x body noret ret_op) - = do (env1, new_ret) <- zonkSyntaxExpr env ret_op - new_body <- zBody env1 body - return (env, LastStmt x new_body noret new_ret) - -zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_ext = bind_arg_ty - , trS_fmap = liftM_op }) - = do { - ; (env1, bind_op') <- zonkSyntaxExpr env bind_op - ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty - ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- traverse (zonkLExpr env2) by - ; using' <- zonkLExpr env2 using - - ; (env3, return_op') <- zonkSyntaxExpr env2 return_op - ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap - ; liftM_op' <- zonkExpr env3 liftM_op - ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') - ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' - , trS_by = by', trS_form = form, trS_using = using' - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = bind_arg_ty' - , trS_fmap = liftM_op' }) } - where - zonkBinderMapEntry env (oldBinder, newBinder) = do - let oldBinder' = zonkIdOcc env oldBinder - newBinder' <- zonkIdBndr env newBinder - return (oldBinder', newBinder') - -zonkStmt env _ (LetStmt x binds) - = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x new_binds) - -zonkStmt env zBody (BindStmt xbs pat body) - = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs) - ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs) - ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs) - ; new_body <- zBody env1 body - ; (env2, new_pat) <- zonkPat env1 pat - ; new_fail <- case xbstc_failOp xbs of - Nothing -> return Nothing - Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f) - ; return ( env2 - , BindStmt (XBindStmtTc - { xbstc_bindOp = new_bind - , xbstc_boundResultType = new_bind_ty - , xbstc_boundResultMult = new_w - , xbstc_failOp = new_fail - }) - new_pat new_body) } - --- Scopes: join > ops (in reverse order) > pats (in forward order) --- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) - = do { (env1, new_mb_join) <- zonk_join env mb_join - ; (env2, new_args) <- zonk_args env1 args - ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty - ; return ( env2 - , ApplicativeStmt new_body_ty new_args new_mb_join) } - where - zonk_join env Nothing = return (env, Nothing) - zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - - get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc - get_pat (_, ApplicativeArgOne _ pat _ _) = pat - get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat - - replace_pat :: LPat GhcTc - -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) - = (op, ApplicativeArgOne fail_op pat a isBody) - replace_pat pat (op, ApplicativeArgMany x a b _ c) - = (op, ApplicativeArgMany x a b pat c) - - zonk_args env args - = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) - ; (env2, new_pats) <- zonkPats env1 (map get_pat args) - ; return (env2, zipWithEqual "zonkStmt" replace_pat - new_pats (reverse new_args_rev)) } - - -- these need to go backward, because if any operators are higher-rank, - -- later operators may introduce skolems that are in scope for earlier - -- arguments - zonk_args_rev env ((op, arg) : args) - = do { (env1, new_op) <- zonkSyntaxExpr env op - ; new_arg <- zonk_arg env1 arg - ; (env2, new_args) <- zonk_args_rev env1 args - ; return (env2, (new_op, new_arg) : new_args) } - zonk_args_rev env [] = return (env, []) - - zonk_arg env (ApplicativeArgOne fail_op pat expr isBody) - = do { new_expr <- zonkLExpr env expr - ; new_fail <- forM fail_op $ \old_fail -> - do { (_, fail') <- zonkSyntaxExpr env old_fail - ; return fail' - } - ; return (ApplicativeArgOne new_fail pat new_expr isBody) } - zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } - -------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc) -zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mapM zonk_rbind flds - ; return (HsRecFields flds' dd) } - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld) - ; new_expr <- zonkLExpr env (hfbRHS fld) - ; return (L l (fld { hfbLHS = new_id - , hfbRHS = new_expr })) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Pats]{Patterns} -* * -************************************************************************ --} - -zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) --- Extend the environment as we go, because it's possible for one --- pattern to bind something that is used in another (inside or --- to the right) -zonkPat env pat = wrapLocSndMA (zonk_pat env) pat - -zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x lpar p rpar) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat x lpar p' rpar) } - -zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; return (env, WildPat ty') } - -zonk_pat env (VarPat x (L l v)) - = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', VarPat x (L l v')) } - -zonk_pat env (LazyPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat x pat') } - -zonk_pat env (BangPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat x pat') } - -zonk_pat env (AsPat x (L loc v) at pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat - ; return (env', AsPat x (L loc v') at pat') } - -zonk_pat env (ViewPat ty expr pat) - = do { expr' <- zonkLExpr env expr - ; (env', pat') <- zonkPat env pat - ; ty' <- zonkTcTypeToTypeX env ty - ; return (env', ViewPat ty' expr' pat') } - -zonk_pat env (ListPat ty pats) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat ty' pats') } - -zonk_pat env (TuplePat tys pats boxed) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat tys' pats' boxed) } - -zonk_pat env (SumPat tys pat alt arity ) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pat') <- zonkPat env pat - ; return (env', SumPat tys' pat' alt arity) } - -zonk_pat env p@(ConPat { pat_args = args - , pat_con_ext = p'@(ConPatTc - { cpt_tvs = tyvars - , cpt_dicts = evs - , cpt_binds = binds - , cpt_wrap = wrapper - , cpt_arg_tys = tys - }) - }) - = assert (all isImmutableTyVar tyvars) $ - do { new_tys <- mapM (zonkTcTypeToTypeX env) tys - ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars - -- Must zonk the existential variables, because their - -- /kind/ need potential zonking. - -- cf typecheck/should_compile/tc221.hs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env3, new_wrapper) <- zonkCoFn env2 wrapper - ; (env', new_args) <- zonkConStuff env3 args - ; pure ( env' - , p - { pat_args = new_args - , pat_con_ext = p' - { cpt_arg_tys = new_tys - , cpt_tvs = new_tyvars - , cpt_dicts = new_evs - , cpt_binds = new_binds - , cpt_wrap = new_wrapper - } - } - ) - } - -zonk_pat env (LitPat x lit) = return (env, LitPat x lit) - -zonk_pat env (SigPat ty pat hs_ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pat') <- zonkPat env pat - ; return (env', SigPat ty' pat' hs_ty) } - -zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) - = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr - ; (env2, mb_neg') <- case mb_neg of - Nothing -> return (env1, Nothing) - Just n -> second Just <$> zonkSyntaxExpr env1 n - - ; lit' <- zonkOverLit env2 lit - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } - -zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) - = do { (env1, e1') <- zonkSyntaxExpr env e1 - ; (env2, e2') <- zonkSyntaxExpr env1 e2 - ; n' <- zonkIdBndr env2 n - ; lit1' <- zonkOverLit env2 lit1 - ; lit2' <- zonkOverLit env2 lit2 - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (extendIdZonkEnv env2 n', - NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } -zonk_pat env (XPat ext) = case ext of - { ExpansionPat orig pat-> - do { (env, pat') <- zonk_pat env pat - ; return $ (env, XPat $ ExpansionPat orig pat') } - ; CoPat co_fn pat ty -> - do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLocA pat) - ; ty' <- zonkTcTypeToTypeX env'' ty - ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') - }} - -zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) - ---------------------------- -zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc - -> TcM (ZonkEnv, HsConPatDetails GhcTc) -zonkConStuff env (PrefixCon tyargs pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon tyargs pats') } - -zonkConStuff env (InfixCon p1 p2) - = do { (env1, p1') <- zonkPat env p1 - ; (env', p2') <- zonkPat env1 p2 - ; return (env', InfixCon p1' p2') } - -zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats) - ; let rpats' = zipWith (\(L l rp) p' -> - L l (rp { hfbRHS = p' })) - rpats pats' - ; return (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking - ---------------------------- -zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc]) -zonkPats env [] = return (env, []) -zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } - -{- -************************************************************************ -* * -\subsection[BackSubst-Foreign]{Foreign exports} -* * -************************************************************************ --} - -zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] - -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls - -zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) -zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co - , fd_fe = spec }) - = return (ForeignExport { fd_name = zonkLIdOcc env i - , fd_sig_ty = undefined, fd_e_ext = co - , fd_fe = spec }) -zonkForeignExport _ for_imp - = return for_imp -- Foreign imports don't need zonking - -zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs - -zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) -zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs - - ; let env_lhs = setZonkType env_inside SkolemiseFlexi - -- See Note [Zonking the LHS of a RULE] - - ; new_lhs <- zonkLExpr env_lhs lhs - ; new_rhs <- zonkLExpr env_inside rhs - - ; return $ rule { rd_tmvs = new_tm_bndrs - , rd_lhs = new_lhs - , rd_rhs = new_rhs } } - where - zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc) - zonk_tm_bndr env (L l (RuleBndr x (L loc v))) - = do { (env', v') <- zonk_it env v - ; return (env', L l (RuleBndr x (L loc v'))) } - zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - - zonk_it env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnvRec env [v'], v') } - | otherwise = assert (isImmutableTyVar v) - zonkTyBndrX env v - -- DV: used to be return (env,v) but that is plain - -- wrong because we may need to go inside the kind - -- of v and zonk there! - -{- -************************************************************************ -* * - Constraints and evidence -* * -************************************************************************ --} - -zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm -zonkEvTerm env (EvExpr e) - = EvExpr <$> zonkCoreExpr env e -zonkEvTerm env (EvTypeable ty ev) - = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev -zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs - , et_binds = ev_binds, et_body = body_id }) - = do { (env0, new_tvs) <- zonkTyBndrsX env tvs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds - ; let new_body_id = zonkIdOcc env2 body_id - ; return (EvFun { et_tvs = new_tvs, et_given = new_evs - , et_binds = new_ev_binds, et_body = new_body_id }) } - -zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr -zonkCoreExpr env (Var v) - | isCoVar v - = Coercion <$> zonkCoVarOcc env v - | otherwise - = return (Var $ zonkIdOcc env v) -zonkCoreExpr _ (Lit l) - = return $ Lit l -zonkCoreExpr env (Coercion co) - = Coercion <$> zonkCoToCo env co -zonkCoreExpr env (Type ty) - = Type <$> zonkTcTypeToTypeX env ty - -zonkCoreExpr env (Cast e co) - = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co -zonkCoreExpr env (Tick t e) - = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks? - -zonkCoreExpr env (App e1 e2) - = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2 -zonkCoreExpr env (Lam v e) - = do { (env1, v') <- zonkCoreBndrX env v - ; Lam v' <$> zonkCoreExpr env1 e } -zonkCoreExpr env (Let bind e) - = do (env1, bind') <- zonkCoreBind env bind - Let bind'<$> zonkCoreExpr env1 e -zonkCoreExpr env (Case scrut b ty alts) - = do scrut' <- zonkCoreExpr env scrut - ty' <- zonkTcTypeToTypeX env ty - b' <- zonkIdBndr env b - let env1 = extendIdZonkEnv env b' - alts' <- mapM (zonkCoreAlt env1) alts - return $ Case scrut' b' ty' alts' - -zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (Alt dc bndrs rhs) - = do (env1, bndrs') <- zonkCoreBndrsX env bndrs - rhs' <- zonkCoreExpr env1 rhs - return $ Alt dc bndrs' rhs' - -zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) -zonkCoreBind env (NonRec v e) - = do v' <- zonkIdBndr env v - e' <- zonkCoreExpr env e - let env1 = extendIdZonkEnv env v' - return (env1, NonRec v' e') -zonkCoreBind env (Rec pairs) - = do (env1, pairs') <- fixM go - return (env1, Rec pairs') - where - go ~(_, new_pairs) = do - let env1 = extendIdZonkEnvRec env (map fst new_pairs) - pairs' <- mapM (zonkCorePair env1) pairs - return (env1, pairs') - -zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr) -zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e - -zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable env (EvTypeableTyCon tycon e) - = do { e' <- mapM (zonkEvTerm env) e - ; return $ EvTypeableTyCon tycon e' } -zonkEvTypeable env (EvTypeableTyApp t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable env (EvTypeableTrFun tm t1 t2) - = do { tm' <- zonkEvTerm env tm - ; t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun tm' t1' t2') } -zonkEvTypeable env (EvTypeableTyLit t1) - = do { t1' <- zonkEvTerm env t1 - ; return (EvTypeableTyLit t1') } - -zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) -zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs - ; return (env, [EvBinds (unionManyBags bs')]) } - -zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) -zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs - ; return (env', EvBinds bs') } - -zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) -zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var -zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs - -zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) -zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) - = do { bs <- readMutVar ref - ; zonkEvBinds env (evBindMapBinds bs) } -zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag) - -zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) -zonkEvBinds env binds - = {-# SCC "zonkEvBinds" #-} - fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) - ; binds' <- mapBagM (zonkEvBind env1) binds - ; return (env1, binds') }) - where - collect_ev_bndrs :: Bag EvBind -> [EvVar] - collect_ev_bndrs = foldr add [] - add (EvBind { eb_lhs = var }) vars = var : vars - -zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) - = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - - -- Optimise the common case of Refl coercions - -- See Note [Optimise coercion zonking] - -- This has a very big effect on some programs (eg #5030) - - ; term' <- case getEqPredTys_maybe (idType var') of - Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (evCoercion (mkReflCo r ty1)) - _other -> zonkEvTerm env term - - ; return (bind { eb_lhs = var', eb_rhs = term' }) } - -{- Note [Optimise coercion zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When optimising evidence binds we may come across situations where -a coercion looks like - cv = ReflCo ty -or cv1 = cv2 -where the type 'ty' is big. In such cases it is a waste of time to zonk both - * The variable on the LHS - * The coercion on the RHS -Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just -use Refl on the right, ignoring the actual coercion on the RHS. - -This can have a very big effect, because the constraint solver sometimes does go -to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) - - -************************************************************************ -* * - Zonking types -* * -************************************************************************ --} - -{- Note [Sharing when zonking to Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: - - In GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to - (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.TcMType. But we - /can't/ do this when zonking a TcType to a Type (#15552, esp - comment:3). Suppose we have - - alpha -> alpha - where - alpha is already unified: - alpha := T{tc-tycon} Int -> Int - and T is knot-tied - - By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, - but the global env contains a mapping "T" :-> T{knot-tied-tc}. See - Note [Type checking recursive type and class declarations] in - GHC.Tc.TyCl. - - Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow - the same path as Note [Sharing in zonking] in GHC.Tc.Utils.TcMType, we'll - update alpha to - alpha := T{knot-tied-tc} Int -> Int - - But alas, if we encounter alpha for a /second/ time, we end up - looking at T{knot-tied-tc} and fall into a black hole. The whole - point of zonkTcTypeToType is that it produces a type full of - knot-tied tycons, and you must not look at the result!! - - To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not - the same as zonkTcTypeToType. (If we distinguished TcType from - Type, this issue would have been a type error!) - -Solutions: (see #15552 for other variants) - -One possible solution is simply not to do the short-circuiting. -That has less sharing, but maybe sharing is rare. And indeed, -that usually turns out to be viable from a perf point of view - -But zonkTyVarOcc implements something a bit better - -* ZonkEnv contains ze_meta_tv_env, which maps - from a MetaTyVar (unification variable) - to a Type (not a TcType) - -* In zonkTyVarOcc, we check this map to see if we have zonked - this variable before. If so, use the previous answer; if not - zonk it, and extend the map. - -* The map is of course stateful, held in a TcRef. (That is unlike - the treatment of lexically-scoped variables in ze_tv_env and - ze_id_env.) - -* In zonkTyVarOcc we read the TcRef to look up the unification - variable: - - if we get a hit we use the zonked result; - - if not, in zonk_meta we see if the variable is `Indirect ty`, - zonk that, and update the map (in finish_meta) - But Nota Bene that the "update map" step must re-read the TcRef - (or, more precisely, use updTcRef) because the zonking of the - `Indirect ty` may have added lots of stuff to the map. See - #19668 for an example where this made an asymptotic difference! - -Is it worth the extra work of carrying ze_meta_tv_env? Some -non-systematic perf measurements suggest that compiler allocation is -reduced overall (by 0.5% or so) but compile time really doesn't -change. But in some cases it makes a HUGE difference: see test -T9198 and #19668. So yes, it seems worth it. --} - -zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type -zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi - , ze_tv_env = tv_env - , ze_meta_tv_env = mtv_env_ref }) tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> lookup_in_tv_env - RuntimeUnk {} -> lookup_in_tv_env - MetaTv { mtv_ref = ref } - -> do { mtv_env <- readTcRef mtv_env_ref - -- See Note [Sharing when zonking to Type] - ; case lookupVarEnv mtv_env tv of - Just ty -> return ty - Nothing -> do { mtv_details <- readTcRef ref - ; zonk_meta ref mtv_details } } - | otherwise -- This should never really happen; - -- TyVars should not occur in the typechecker - = lookup_in_tv_env - - where - lookup_in_tv_env -- Look up in the env just as we do for Ids - = case lookupVarEnv tv_env tv of - Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv - -- This can happen for RuntimeUnk variables (which - -- should stay as RuntimeUnk), but I think it should - -- not happen for SkolemTv. - mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv - - Just tv' -> return (mkTyVarTy tv') - - zonk_meta ref Flexi - = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) - ; ty <- commitFlexi flexi tv kind - ; writeMetaTyVarRef tv ref ty -- Belt and braces - ; finish_meta ty } - - zonk_meta _ (Indirect ty) - = do { zty <- zonkTcTypeToTypeX env ty - ; finish_meta zty } - - finish_meta ty - = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) - ; return ty } - -lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar -lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv - = case lookupVarEnv tv_env tv of - Just tv -> tv - Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) - -commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type --- Only monadic so we can do tc-tracing -commitFlexi flexi tv zonked_kind - = case flexi of - SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) - - DefaultFlexi - -- Normally, RuntimeRep variables are defaulted in TcMType.defaultTyVar - -- But that sees only type variables that appear in, say, an inferred type - -- Defaulting here in the zonker is needed to catch e.g. - -- y :: Bool - -- y = (\x -> True) undefined - -- We need *some* known RuntimeRep for the x and undefined, but no one - -- will choose it until we get here, in the zonker. - | isRuntimeRepTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) - ; return liftedRepTy } - | isLevityTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv) - ; return liftedDataConTy } - | isMultiplicityTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) - ; return manyDataConTy } - | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv - -> do { addErr $ TcRnCannotDefaultConcrete origin - ; return (anyTypeOfKind zonked_kind) } - | otherwise - -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) - ; return (anyTypeOfKind zonked_kind) } - - RuntimeUnkFlexi - -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) - ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad - - NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) - - where - name = tyVarName tv - -zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion -zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv - | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env - = return $ mkCoVarCo cv' - | otherwise - = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') } - -zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion -zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCoToCo env co - ; checkCoercionHole cv co' } - - -- This next case should happen only in the presence of - -- (undeferred) type errors. Originally, I put in a panic - -- here, but that caused too many uses of `failIfErrsM`. - Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) - ; cv' <- zonkCoVar cv - ; return $ mkCoVarCo cv' } } - -- This will be an out-of-scope variable, but keeping - -- this as a coercion hole led to #15787 - -zonk_tycomapper :: TyCoMapper ZonkEnv TcM -zonk_tycomapper = TyCoMapper - { tcm_tyvar = zonkTyVarOcc - , tcm_covar = zonkCoVarOcc - , tcm_hole = zonkCoHole - , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv - , tcm_tycon = zonkTcTyConToTyCon } - --- Zonk a TyCon by changing a TcTyCon to a regular TyCon -zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon -zonkTcTyConToTyCon tc - | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) - ; case thing of - ATyCon real_tc -> return real_tc - _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } - | otherwise = return tc -- it's already zonked - --- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. -zonkTcTypeToType :: TcType -> TcM Type -zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty - -zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType) -zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m - <*> zonkTcTypeToTypeX env ty - -zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type -zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] -zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) - = mapTyCoX zonk_tycomapper - -zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type] -zonkScaledTcTypesToTypesX env scaled_tys = - mapM (zonkScaledTcTypeToTypeX env) scaled_tys - -zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo -zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; gdm_spec' <- zonk_gdm gdm_spec - ; return (name, ty', gdm_spec') } - where - zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) - -> TcM (Maybe (DefMethSpec (SrcSpan, Type))) - zonk_gdm Nothing = return Nothing - zonk_gdm (Just VanillaDM) = return (Just VanillaDM) - zonk_gdm (Just (GenericDM (loc, ty))) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; return (Just (GenericDM (loc, ty'))) } - ---------------------------------------- -{- Note [Zonking the LHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] - -We need to gather the type variables mentioned on the LHS so we can -quantify over them. Example: - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)) and we do -not want to zap the unbound meta-tyvar 'alpha' to Any, because that -limits the applicability of the rule. Instead, we want to quantify -over it! - -We do this in two stages. - -* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We - do this by using zonkTvSkolemising as the UnboundTyVarZonker in the - ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a - UnboundTyVarZonker.) - -* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds - Note [Free tyvars on rule LHS] - -Quantifying here is awkward because (a) the data type is big and (b) -finding the free type vars of an expression is necessarily monadic -operation. (consider /\a -> f @ b, where b is side-effected to a) --} 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 @@ -15,7 +15,6 @@ checkTySynRhs, checkEscapingKind, checkValidCoAxiom, checkValidCoAxBranch, checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, - arityErr, checkTyConTelescope, ) where @@ -27,22 +26,22 @@ -- friends: import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) import GHC.Tc.Solver ( simplifyAmbiguityCheck ) -import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) +import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family +import GHC.Tc.Zonk.TcType import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) import GHC.Core.Type -import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) +import GHC.Core.Unify ( typesAreApart, tcMatchTyX_BM, BindFlag(..) ) import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.Class @@ -54,8 +53,6 @@ import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches , InjectivityCheckResult(..) ) -import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) -import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) import GHC.Hs import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt @@ -65,8 +62,10 @@ import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Types.Var ( VarBndr(..), isInvisibleFunArg, mkTyVar ) +import GHC.Types.Var ( VarBndr(..), isInvisibleFunArg, mkTyVar, tyVarName ) +import GHC.Types.SourceFile import GHC.Types.SrcLoc +import GHC.Types.TyThing ( TyThing(..) ) import GHC.Types.Unique.Set( isEmptyUniqSet ) import GHC.Utils.FV @@ -83,7 +82,6 @@ import Data.Foldable import Data.Function import Data.List ( (\\) ) -import qualified Data.List.NonEmpty as NE {- ************************************************************************ @@ -232,19 +230,20 @@ checkAmbiguity :: UserTypeCtxt -> Type -> TcM () checkAmbiguity ctxt ty | wantAmbiguityCheck ctxt - = do { traceTc "Ambiguity check for" (ppr ty) + = do { traceTc "Ambiguity check for {" (ppr ty) -- Solve the constraints eagerly because an ambiguous type -- can cause a cascade of further errors. Since the free -- tyvars are skolemised, we can safely use tcSimplifyTop ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ - captureConstraints $ - tcSubTypeAmbiguity ctxt ty ty - -- See Note [Ambiguity check and deep subsumption] - -- in GHC.Tc.Utils.Unify - ; simplifyAmbiguityCheck ty wanted + ; unless allow_ambiguous $ + do { (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ + captureConstraints $ + tcSubTypeAmbiguity ctxt ty ty + -- See Note [Ambiguity check and deep subsumption] + -- in GHC.Tc.Utils.Unify + ; simplifyAmbiguityCheck ty wanted } - ; traceTc "Done ambiguity check for" (ppr ty) } + ; traceTc "} Done ambiguity check for" (ppr ty) } | otherwise = return () @@ -296,7 +295,7 @@ -- inside type family arguments (see #20241). fail_with :: Type -> TcM () - fail_with msg = do { env0 <- tcInitTidyEnv + fail_with msg = do { env0 <- liftZonkM tcInitTidyEnv ; let (env1, tidy_msg) = tidyOpenType env0 msg ; failWithTcM (env1, TcRnUserTypeError tidy_msg) } @@ -419,7 +418,7 @@ _ -> panic "checkValidType" -- Can't happen; not used for *user* sigs - ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) ; expand <- initialExpandMode ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt , ve_rank = rank, ve_expand = expand } @@ -442,7 +441,7 @@ checkValidMonoType :: Type -> TcM () -- Assumes argument is fully zonked checkValidMonoType ty - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + = do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) ; expand <- initialExpandMode ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt , ve_rank = MustBeMonoType, ve_expand = expand } @@ -475,7 +474,7 @@ MkT :: forall l. T @l :: TYPE (BoxedRep l) which is ill-kinded. -For ordinary /user-written type signatures f :: blah, we make this +For ordinary /user-written/ type signatures f :: blah, we make this check as part of kind-checking the type signature in tcHsSigType; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType. @@ -571,6 +570,8 @@ typeOrKindCtxt (TySynKindCtxt {}) = OnlyKindCtxt typeOrKindCtxt (TyFamResKindCtxt {}) = OnlyKindCtxt +-- These cases are also described in Note [No constraints in kinds], so any +-- change here should be reflected in that note. typeOrKindCtxt (TySynCtxt {}) = BothTypeAndKindCtxt -- Type synonyms can have types and kinds on their RHSs typeOrKindCtxt (GhciCtxt {}) = BothTypeAndKindCtxt @@ -594,7 +595,6 @@ -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the -- context for a kind of a type, where the arbitrary use of constraints is -- currently disallowed. --- (See @Note [Constraints in kinds]@ in "GHC.Core.TyCo.Rep".) allConstraintsAllowed :: UserTypeCtxt -> Bool allConstraintsAllowed = typeLevelUserTypeCtxt @@ -827,7 +827,8 @@ where (arg_rank, res_rank) = funArgResRank rank -check_type _ ty = pprPanic "check_type" (ppr ty) +check_type _ ty@(ForAllTy {}) = pprPanic "check_type" (ppr ty) +check_type _ ty@(CoercionTy {}) = pprPanic "check_type" (ppr ty) ---------------------------------------- check_syn_tc_app :: ValidityEnv @@ -985,10 +986,9 @@ checkConstraintsOK ve theta ty | null theta = return () | allConstraintsAllowed (ve_ctxt ve) = return () - | otherwise - = -- We are in a kind, where we allow only equality predicates - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263 - checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty)) + | otherwise -- We are unambiguously in a kind; see + -- Note [No constraints in kinds] + = failWithTcM (env, TcRnConstraintInKind (tidyType env ty)) where env = ve_tidy_env ve checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM () @@ -999,7 +999,25 @@ no_vdq = all (isInvisibleForAllTyFlag . binderFlag) tvbs ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve -{- +{- Note [No constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC does not allow constraints in kinds. Equality constraints +in kinds were allowed from GHC 8.0, but this "feature" was removed +as part of Proposal #547 (https://github.com/ghc-proposals/ghc-proposals/pull/547), +which contains further context and motivation for the removal. + +The lack of constraints in kinds is enforced by checkConstraintsOK, which +uses the UserTypeCtxt to determine if we are unambiguously checking a kind. +There are two ambiguous contexts (constructor BothTypeAndKindCtxt of TypeOrKindCtxt) +as written in typeOfKindCtxt: + - TySynCtxt: this is the RHS of a type synonym. We check the expansion of type + synonyms for constraints, so this is handled at the usage site of the synonym. + - GhciCtxt: This is the type in a :kind command. A constraint here does not cause + any trouble, because the type cannot be used to classify a type. + +Beyond these two cases, we also promote data constructors. We check for constraints +in data constructor types in GHC.Tc.Gen.HsType.tcTyVar. + Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* @@ -1077,7 +1095,7 @@ -- Assumes argument is fully zonked checkValidTheta ctxt theta = addErrCtxtM (checkThetaCtxt ctxt theta) $ - do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) + do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) ; expand <- initialExpandMode ; check_valid_theta env ctxt expand theta } @@ -1210,7 +1228,7 @@ check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () check_class_pred env dflags ctxt pred cls tys - | isEqPredClass cls -- (~) and (~~) are classified as classes, + | isEqualityClass cls -- (~) and (~~) and Coercible are classified as classes, -- but here we want to treat them as equalities = -- Equational constraints are valid in all contexts, and -- we do not need to check e.g. for FlexibleContexts here, so just do nothing @@ -1260,30 +1278,18 @@ = do { result <- matchGlobalInst dflags False cls tys ; case result of OneInst { cir_what = what } - -> let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints) - noHints - (simplifiable_constraint_warn what) - in addDiagnosticTc dia - _ -> return () } + -> addDiagnosticTc (TcRnSimplifiableConstraint pred what) + _ -> return () } where - pred = mkClassPred cls tys - - simplifiable_constraint_warn :: InstanceWhat -> SDoc - simplifiable_constraint_warn what - = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)) - <+> text "matches") - 2 (ppr what) - , hang (text "This makes type inference for inner bindings fragile;") - 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] + pred = tidyType env (mkClassPred cls tys) {- Note [Simplifiable given constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A type signature like f :: Eq [(a,b)] => a -> b -is very fragile, for reasons described at length in GHC.Tc.Solver.Interact +is very fragile, for reasons described at length in GHC.Tc.Solver.Dict Note [Instance and Given overlap]. As that Note discusses, for the -most part the clever stuff in GHC.Tc.Solver.Interact means that we don't use a +most part the clever stuff in GHC.Tc.Solver.Dict means that we don't use a top-level instance if a local Given might fire, so there is no fragility. But if we /infer/ the type of a local let-binding, things can go wrong (#11948 is an example, discussed in the Note). @@ -1295,7 +1301,7 @@ The warning only fires if the constraint in the signature matches the top-level instances in only one way, and with no unifiers -- that is, under the same circumstances that -GHC.Tc.Solver.Interact.matchInstEnv fires an interaction with the top +GHC.Tc.Instance.Class.matchInstEnv fires an interaction with the top level instances. For example (#13526), consider instance {-# OVERLAPPABLE #-} Eq (T a) where ... @@ -1364,7 +1370,7 @@ generalized actually. -} -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, SDoc) checkThetaCtxt ctxt theta env = return ( env , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) @@ -1376,8 +1382,7 @@ -- ignoring the /invisible/ arguments, which the user does not see. -- (e.g. #10516) tyConArityErr tc tks - = arityErr (ppr (tyConFlavour tc)) (tyConName tc) - tc_type_arity tc_type_args + = TcRnArityMismatch (ATyCon tc) tc_type_arity tc_type_args where vis_tks = filterOutInvisibleTypes tc tks @@ -1386,17 +1391,6 @@ tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) tc_type_args = length vis_tks -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage -arityErr what name n m - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hsep [ text "The" <+> what, quotes (ppr name), text "should have", - n_arguments <> comma, text "but has been given", - if m==0 then text "none" else int m] - where - n_arguments | n == 0 = text "no arguments" - | n == 1 = text "1 argument" - | True = hsep [int n, text "arguments"] - {- ************************************************************************ * * @@ -1417,9 +1411,8 @@ checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags - ; is_boot <- tcIsHsBootOrSig - ; is_sig <- tcIsHsig - ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args + ; hsc_src <- tcHscSource + ; check_special_inst_head dflags hsc_src ctxt clas cls_args ; checkValidTypePats (classTyCon clas) cls_args } @@ -1449,16 +1442,17 @@ -} -check_special_inst_head :: DynFlags -> Bool -> Bool - -> UserTypeCtxt -> Class -> [Type] -> TcM () +check_special_inst_head :: DynFlags -> HscSource -> UserTypeCtxt + -> Class -> [Type] -> TcM () -- Wow! There are a surprising number of ad-hoc special cases here. -- TODO: common up the logic for special typeclasses (see GHC ticket #20441). -check_special_inst_head dflags is_boot is_sig ctxt clas cls_args +check_special_inst_head dflags hs_src ctxt clas cls_args - -- If not in an hs-boot file, abstract classes cannot have instances + -- Abstract classes cannot have instances, except in hs-boot or signature files. | isAbstractClass clas - , not is_boot - = failWithTc (TcRnAbstractClassInst clas) + , hs_src == HsSrcFile + = fail_with_inst_err $ IllegalInstanceHead + $ InstHeadAbstractClass clas -- Complain about hand-written instances of built-in classes -- Typeable, KnownNat, KnownSymbol, Coercible, HasField. @@ -1467,31 +1461,34 @@ -- allow a standalone deriving declaration: they are no-ops, -- and we warn about them in GHC.Tc.Deriv.deriveStandalone. | clas_nm == typeableClassName - , not is_sig + , not (hs_src == HsigFile) -- Note [Instances of built-in classes in signature files] , hand_written_bindings - = failWithTc $ TcRnSpecialClassInst clas False + = fail_with_inst_err $ IllegalSpecialClassInstance clas False -- Handwritten instances of KnownNat/KnownChar/KnownSymbol -- are forbidden outside of signature files (#12837). -- Derived instances are forbidden completely (#21087). | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ] - , (not is_sig && hand_written_bindings) || derived_instance + , (not (hs_src == HsigFile) && hand_written_bindings) || derived_instance -- Note [Instances of built-in classes in signature files] - = failWithTc $ TcRnSpecialClassInst clas False + = fail_with_inst_err $ IllegalSpecialClassInstance clas False -- For the most part we don't allow -- instances for (~), (~~), or Coercible; -- but we DO want to allow them in quantified constraints: -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... - | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName, withDictClassName ] + | clas_nm `elem` + [ heqTyConName, eqTyConName, coercibleTyConName + , withDictClassName, unsatisfiableClassName ] , not quantified_constraint - = failWithTc $ TcRnSpecialClassInst clas False + = fail_with_inst_err $ IllegalSpecialClassInstance clas False -- Check for hand-written Generic instances (disallowed in Safe Haskell) | clas_nm `elem` genericClassNames , hand_written_bindings - = do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True) + = do { when (safeLanguageOn dflags) $ + fail_with_inst_err $ IllegalSpecialClassInstance clas True ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } | clas_nm == hasFieldClassName @@ -1506,12 +1503,19 @@ -- Check language restrictions on the args to the class | check_h98_arg_shape - , Just msg <- mb_ty_args_msg - = failWithTc (instTypeErr clas cls_args msg) + , Just illegal_head <- mb_ty_args_type + = fail_with_inst_err $ IllegalInstanceHead illegal_head | otherwise = pure () where + + fail_with_inst_err err = + failWithTc $ TcRnIllegalInstance + $ IllegalClassInstance + (TypeThing $ mkClassPred clas cls_args) + $ err + clas_nm = getName clas ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args @@ -1545,34 +1549,19 @@ SigmaCtxt -> True _ -> False - head_type_synonym_msg = parens ( - text "All instance types must be of the form (T t1 ... tn)" $$ - text "where T is not a synonym." $$ - text "Use TypeSynonymInstances if you want to disable this.") - - head_type_args_tyvars_msg = parens (vcat [ - text "All instance types must be of the form (T a1 ... an)", - text "where a1 ... an are *distinct type variables*,", - text "and each type variable appears at most once in the instance head.", - text "Use FlexibleInstances if you want to disable this."]) - - head_one_type_msg = parens $ - text "Only one type can be given in an instance head." $$ - text "Use MultiParamTypeClasses if you want to allow more, or zero." - - mb_ty_args_msg + mb_ty_args_type | not (xopt LangExt.TypeSynonymInstances dflags) , not (all tcInstHeadTyNotSynonym ty_args) - = Just head_type_synonym_msg + = Just InstHeadTySynArgs | not (xopt LangExt.FlexibleInstances dflags) , not (all tcInstHeadTyAppAllTyVars ty_args) - = Just head_type_args_tyvars_msg + = Just InstHeadNonTyVarArgs | length ty_args /= 1 , not (xopt LangExt.MultiParamTypeClasses dflags) , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) - = Just head_one_type_msg + = Just InstHeadMultiParam | otherwise = Nothing @@ -1629,32 +1618,38 @@ dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b -- Don't bother in the kind of a forall -instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage -instTypeErr cls tys msg - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (hang (text "Illegal instance declaration for") - 2 (quotes (pprClassPred cls tys))) - 2 msg - -- | See Note [Validity checking of HasField instances] checkHasFieldInst :: Class -> [Type] -> TcM () -checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] = +checkHasFieldInst cls tys@[_k_ty, lbl_ty, r_ty, _a_ty] = case splitTyConApp_maybe r_ty of - Nothing -> whoops (text "Record data type must be specified") + Nothing -> add_err IllegalHasFieldInstanceNotATyCon Just (tc, _) | isFamilyTyCon tc - -> whoops (text "Record data type may not be a data family") - | otherwise -> case isStrLitTy x_ty of + -> add_err IllegalHasFieldInstanceFamilyTyCon + | otherwise -> case isStrLitTy lbl_ty of Just lbl - | isJust (lookupTyConFieldLabel (FieldLabelString lbl) tc) - -> whoops (ppr tc <+> text "already has a field" - <+> quotes (ppr lbl)) - | otherwise -> return () + | let lbl_str = FieldLabelString lbl + , isJust (lookupTyConFieldLabel lbl_str tc) + -> add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str + | otherwise + -> return () Nothing - | null (tyConFieldLabels tc) -> return () - | otherwise -> whoops (ppr tc <+> text "has fields") + -- If the label is not a literal, we need to ensure it can't unify + -- with any of the field labels of the TyCon. + | null (tyConFieldLabels tc) + -- No field labels at all: nothing to check. + || typesAreApart (typeKind lbl_ty) typeSymbolKind + -- If the label has a type whose kind can't unify with Symbol, + -- then it definitely can't unify with any of the field labels. + -> return () + | otherwise + -> add_err $ IllegalHasFieldInstanceTyConHasFields tc lbl_ty where - whoops = addErrTc . instTypeErr cls tys + add_err err = addErrTc $ TcRnIllegalInstance + $ IllegalClassInstance + (TypeThing $ mkClassPred cls tys) + $ IllegalHasFieldInstance err + checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) {- Note [Casts during validity checking] @@ -1675,7 +1670,7 @@ Note [Validity checking of HasField instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The HasField class has magic constraint solving behaviour (see Note -[HasField instances] in GHC.Tc.Solver.Interact). However, we permit users to +[HasField instances] in GHC.Tc.Instance.Class). However, we permit users to declare their own instances, provided they do not clash with the built-in behaviour. In particular, we forbid: @@ -1694,35 +1689,166 @@ Note [Valid 'deriving' predicate] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. -See Note [Exotic derived instance contexts] in GHC.Tc.Deriv.Infer. However the predicate is -here because it is quite similar to checkInstTermination. +In a 'derived' instance declaration, we *infer* the context. It's a bit unclear +what rules we should apply for this; the Haskell report is silent. Obviously, +constraints like `Eq a` are fine, but what about -It checks for two things: + data T f a = MkT (f a) deriving Eq -(VD1) The Paterson conditions; see Note [Paterson conditions] - Not on do we want to check for termination (of course), but it also - deals with a nasty corner case: - instance C a b => D (T a) where ... - Note that 'b' isn't a parameter of T. This gives rise to all sorts of - problems; in particular, it's hard to compare solutions for equality - when finding the fixpoint, and that means the inferContext loop does - not converge. See #5287, #21302 +where we'd get an `Eq (f a)` constraint. That's probably fine too. -(VD2) No type constructors; no foralls, no equalities: - see Note [Exotic derived instance contexts] in GHC.Tc.Deriv.Infer +On the other hand, we don't want to allow *every* inferred constraint, as there +are some particularly complex constraints that are tricky to handle. If GHC +encounters a constraint that is too complex, it will reject it, and you will +have to use StandaloneDeriving to manually specify the instance context that +you want. - We check the no-type-constructor bit using tyConsOfType. - Wrinkle: we look only at the /visible/ arguments of the class type - constructor. Including the non-visible arguments can cause the following, - perfectly valid instance to be rejected: - class Category (cat :: k -> k -> *) where ... - newtype T (c :: * -> * -> *) a b = MkT (c a b) - instance Category c => Category (T c) where ... - since the first argument to Category is a non-visible *, which has a - type constructor! See #11833. +There are two criteria for a constraint inferred by a `deriving` clause to be +considered valid, which are described below as (VD1) and (VD2). (Here, "VD" +stands for "valid deriving".) `validDerivPred` implements these checks. While +`validDerivPred` is similar to other things defined in GHC.Tc.Deriv.Infer, we +define it here in GHC.Tc.Validity because it is quite similar to +`checkInstTermination`. +----------------------------------- +-- (VD1) The Paterson conditions -- +----------------------------------- +Constraints must satisfy the Paterson conditions (see Note [Paterson +conditions]) to be valid. Not only does this check for termination (of course), +but it also deals with a nasty corner case: + + instance C a b => D (T a) where ... + +Note that `b` isn't a parameter of T. This gives rise to all sorts of +problems; in particular, it's hard to compare solutions for equality when +finding the fixpoint, and that means the +GHC.Tc.Deriv.Infer.simplifyInstanceContexts loop does not converge. +See #5287 and #21302. + +Another common situation in which a derived instance's context fails to meet +the Paterson conditions is when a constraint mentions a type variable more +often than the instance head, e.g., + + data Fix f = In (f (Fix f)) deriving Eq + +This would result in the following derived `Eq` instance: + + instance Eq (f (Fix f)) => Eq (Fix f) + +Because `f` is mentioned more often in the `Eq (f (Fix f))` constraint than in +the instance head `Eq (Fix f)`, GHC rejects this instance. + +This is a somewhat contentious restriction, and some have suggested that +instances like this one should be accepted if UndecidableInstances is enabled +(see #15868 for one such discussion). If we *do* lift this restriction in the +future, we should make sure to still meet the termination conditions. If not, +the deriving mechanism generates larger and larger constraints. Example: + + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate: + + instance (Show (Succ a), Show a) => Show (Seq a) + +and then: + + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) + +and so on. Instead we want to complain of no instance for (Show (Succ a)). + +--------------------------------- +-- (VD2) No exotic constraints -- +--------------------------------- + +A constraint must satisfy one of the following properties in order to be valid: + +* It is a `ClassPred` of the form `C a_1 ... a_n`, where C is a type class + constructor and a_1, ..., a_n are either raw type variables or applications + of type variables (e.g., `f a`). +* It is an `IrredPred` of the form `c a_1 ... a_n`, where `c` is a raw type + variable and a_1, ..., a_n are either raw type variables or applications of + type variables (e.g., `f a`). + +If a constraint does not meet either of these properties, it is considered +*exotic*. A constraint will be exotic if it contains: + +* Other type constructors (besides the class in a `ClassPred`), +* Foralls, or +* Equalities + +A common form of exotic constraint is one that mentions another type +constructor. For example, given the following: + + data NotAShowInstance + data Foo = MkFoo Int NotAShowInstance deriving Show + +GHC would attempt to generate the following derived `Show` instance: + + instance (Show Int, Show NotAShowInstance) => Show Foo + +Note that because there is a top-level `Show Int` instance, GHC is able to +simplify away the inferred `Show Int` constraint. However, it cannot do the +same for the `Show NotAShowInstance` constraint. One possibility would be to +generate this instance: + + instance Show NotAShowInstance => Show Foo + +But this is almost surely not what we want most of the time. For this reason, +we reject the constraint above as being exotic. + +Here are some other interesting examples: + +* Derived instances whose instance context would mention TypeError, such as the + code from the deriving/should_fail/T14339 test case, are exotic. For example: + + newtype Foo = Foo Int + + class Bar a where + bar :: a + + instance (TypeError (Text "Boo")) => Bar Foo where + bar = undefined + + newtype Baz = Baz Foo + deriving Bar + + The `deriving Bar` clause would generate this instance: + + instance TypeError (Text "Boo") => Bar Baz + + The instance context is exotic, as `TypeError` is not a type constructor, and + `Text "Boo"` is not an application of type variables. As such, GHC rejects + it. This has the desirable side effect of causing the TypeError to fire in + the resulting error message. + +* The following `IrredPred`s are not exotic: + + instance c => C (T c a) + instance c a => C (T c a) + + This `IrredPred`, however, *is* exotic: + + instance c NotAShowInstance => C (T c) + + This is rejected for the same reasons that we do not permit a `ClassPred` + with a type constructor argument, such as the `Show NotAShowInstance` example + above. + +As part of implementing this check, GHC calls `tyConsOfType` on the arguments +of the constraint, ensuring that there are no other type constructors. +Wrinkle: for `ClassPred`s, we look only at the /visible/ arguments of the class +type constructor. Including the non-visible arguments can cause the following, +perfectly valid instance to be rejected: + + class Category (cat :: k -> k -> Type) where ... + newtype T (c :: Type -> Type -> Type) a b = MkT (c a b) + instance Category c => Category (T c) where ... + +since the first argument to `Category` is a non-visible `Type`, which has a type +constructor! See #11833. + Note [Equality class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't have users writing instances for the equality classes. But we @@ -1734,23 +1860,17 @@ -- See Note [Valid 'deriving' predicate] validDerivPred head_size pred = case classifyPredType pred of - EqPred {} -> False -- Reject equality constraints - ForAllPred {} -> False -- Rejects quantified predicates + EqPred {} -> False -- Reject equality constraints (VD2) + ForAllPred {} -> False -- Rejects quantified predicates (VD2) - ClassPred cls tys -> check_size (pSizeClassPred cls tys) - && isEmptyUniqSet (tyConsOfTypes visible_tys) + ClassPred cls tys -> check_size (pSizeClassPred cls tys) -- (VD1) + && isEmptyUniqSet (tyConsOfTypes visible_tys) -- (VD2) where - visible_tys = filterOutInvisibleTypes (classTyCon cls) tys -- (VD2) + -- See the wrinkle about visible arguments in (VD2) + visible_tys = filterOutInvisibleTypes (classTyCon cls) tys - IrredPred {} -> check_size (pSizeType pred) - -- Very important that we do the "too many variable occurrences" - -- check here, via check_size. Example (test T21302): - -- instance c Eq a => Eq (BoxAssoc a) - -- data BAD = BAD (BoxAssoc Int) deriving( Eq ) - -- We don't want to accept an inferred predicate (c0 Eq Int) - -- from that `deriving(Eq)` clause, because the c0 is fresh, - -- so we'll think it's a "new" one, and loop in - -- GHC.Tc.Deriv.Infer.simplifyInstanceContexts + IrredPred {} -> check_size (pSizeType pred) -- (VD1) + && isEmptyUniqSet (tyConsOfType pred) -- (VD2) where check_size pred_size = isNothing (pred_size `ltPatersonSize` head_size) @@ -1834,15 +1954,15 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty = case tau of -- See Note [Instances and constraint synonyms] - TyConApp tc inst_tys -> case tyConClass_maybe tc of - Nothing -> failWithTc (TcRnIllegalClassInst (tyConFlavour tc)) - Just clas -> do + TyConApp tc inst_tys + | Just clas <- tyConClass_maybe tc + -> do { setSrcSpanA head_loc $ checkValidInstHead ctxt clas inst_tys ; traceTc "checkValidInstance {" (ppr ty) - ; env0 <- tcInitTidyEnv + ; env0 <- liftZonkM $ tcInitTidyEnv ; expand <- initialExpandMode ; check_valid_theta env0 ctxt expand theta @@ -1863,17 +1983,25 @@ ; traceTc "cvi 2" (ppr ty) - ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - IsValid -> return () -- Check succeeded - NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) - - ; traceTc "End checkValidInstance }" empty + ; case checkInstCoverage undecidable_ok clas theta inst_tys of + IsValid + -> return () -- Check succeeded + NotValid coverageInstErr + -> addErrTc $ mk_err + $ IllegalInstanceFailsCoverageCondition clas coverageInstErr - ; return () } - _ -> failWithTc (TcRnNoClassInstHead tau) + ; traceTc "End checkValidInstance }" empty } + | otherwise + -> failWithTc $ mk_err $ IllegalInstanceHead + $ InstHeadNonClass (Just tc) + _ -> failWithTc $ mk_err $ IllegalInstanceHead + $ InstHeadNonClass Nothing where (theta, tau) = splitInstTyForValidity ty + mk_err err = TcRnIllegalInstance + $ IllegalClassInstance (TypeThing tau) err + -- The location of the "head" of the instance head_loc = getLoc (getLHsInstDeclHead hs_type) @@ -1934,40 +2062,9 @@ where check2 pred_size = case pred_size `ltPatersonSize` head_size of - Just ps_failure -> failWithTc $ mkInstSizeError ps_failure head_pred pred + Just pc_failure -> failWithTc $ TcRnPatersonCondFailure pc_failure InInstanceDecl pred head_pred Nothing -> return () - -mkInstSizeError :: PatersonSizeFailure -> TcPredType -> TcPredType -> TcRnMessage -mkInstSizeError ps_failure head_pred pred - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ main_msg - , parens undecidableMsg ] - where - pp_head = text "instance head" <+> quotes (ppr head_pred) - pp_pred = text "constraint" <+> quotes (ppr pred) - - main_msg = case ps_failure of - PSF_TyFam tc -> -- See (PC3) of Note [Paterson conditions] - hang (text "Illegal use of type family" <+> quotes (ppr tc)) - 2 (text "in the" <+> pp_pred) - PSF_TyVar tvs -> hang (occMsg tvs) - 2 (sep [ text "in the" <+> pp_pred - , text "than in the" <+> pp_head ]) - PSF_Size -> hang (text "The" <+> pp_pred) - 2 (sep [ text "is no smaller than", text "the" <+> pp_head ]) - -occMsg :: [TyVar] -> SDoc -occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> pp_occurs <+> text "more often" - where - pp_occurs | isSingleton tvs = text "occurs" - | otherwise = text "occur" - -undecidableMsg :: SDoc -undecidableMsg = text "Use UndecidableInstances to permit this" - - {- Note [Instances and constraint synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, we don't allow instances for constraint synonyms at all. @@ -2022,8 +2119,7 @@ -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch) + = do { let dia = TcRnInaccessibleCoAxBranch fam_tc cur_branch ; addDiagnosticAt (coAxBranchSpan cur_branch) dia ; return prev_branches } | otherwise @@ -2139,10 +2235,11 @@ extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv - Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ - hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion]) + Nothing -> failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault + $ AssocDefaultBadArgs fam_tc pats + $ AssocDefaultNonTyVarArg (pat, pat_vis) -- Checks that no type variables in an associated default declaration are -- duplicated. If that is the case, throw an error. @@ -2156,23 +2253,13 @@ check_all_distinct_tvs cpt_tvs_vis = let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ - (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ - hang (text "Illegal duplicate variable" - <+> quotes (ppr pat_tv) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion])) + (\d -> failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault + $ AssocDefaultBadArgs fam_tc pats + $ AssocDefaultDuplicateTyVars d) dups - ppr_eqn :: SDoc - ppr_eqn = - quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) - <+> equals <+> text "...") - - suggestion :: SDoc - suggestion = text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be distinct type variables" - checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS -> [TcRnMessage] @@ -2190,30 +2277,11 @@ lhs_size = pSizeTypes lhs_tys check (tc, tys) | not (isStuckTypeFamily tc) -- (TF1) - , Just ps_failure <- pSizeTypes tys `ltPatersonSize` lhs_size -- (TF2) - = Just $ mkFamSizeError ps_failure (TyConApp lhs_tc lhs_tys) (TyConApp tc tys) + , Just pc_failure <- pSizeTypes tys `ltPatersonSize` lhs_size -- (TF2) + = Just $ TcRnPatersonCondFailure pc_failure InTyFamEquation (TyConApp lhs_tc lhs_tys) (TyConApp tc tys) | otherwise = Nothing -mkFamSizeError :: PatersonSizeFailure -> Type -> Type -> TcRnMessage -mkFamSizeError ps_failure lhs fam_call - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ main_msg - , parens undecidableMsg ] - where - pp_lhs = text "LHS of the family instance" <+> quotes (ppr lhs) - pp_call = text "type-family application" <+> quotes (ppr fam_call) - - main_msg = case ps_failure of - PSF_TyFam tc -> -- See (PC3) of Note [Paterson conditions] - hang (text "Illegal nested use of type family" <+> quotes (ppr tc)) - 2 (text "in the arguments of the" <+> pp_call) - PSF_TyVar tvs -> hang (occMsg tvs) - 2 (sep [ text "in the" <+> pp_call - , text "than in the" <+> pp_lhs ]) - PSF_Size -> hang (text "The" <+> pp_call) - 2 (sep [ text "is no smaller than", text "the" <+> pp_lhs ]) - ----------------- checkFamPatBinders :: TyCon -> [TcTyVar] -- Bound on LHS of family instance @@ -2236,15 +2304,14 @@ -- In both cases, 'k' is not bound on the LHS, but is used on the RHS -- We catch the former in kcDeclHeader, and the latter right here -- See Note [Check type-family instance binders] - ; check_tvs bad_rhs_tvs (text "mentioned in the RHS") - (text "bound on the LHS of") + ; check_tvs (FamInstRHSOutOfScopeTyVars (Just (fam_tc, pats, dodgy_tvs))) + bad_rhs_tvs -- Check for explicitly forall'd variable that is not bound on LHS -- data instance forall a. T Int = MkT Int -- See Note [Unused explicitly bound variables in a family pattern] -- See Note [Check type-family instance binders] - ; check_tvs bad_qtvs (text "bound by a forall") - (text "used in") + ; check_tvs FamInstLHSUnusedBoundTyVars bad_qtvs } where cpt_tvs = tyCoVarsOfTypes pats @@ -2265,20 +2332,10 @@ -- Used on RHS but not bound on LHS dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs - check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs - <+> isOrAre tvs <+> what <> comma) - 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" - , mk_extra tvs ]) - - -- mk_extra: #7536: give a decent error message for - -- type T a = Int - -- type instance F (T a) = a - mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $ - hang (text "The real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) - + check_tvs mk_err tvs + = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + mk_err (map tyVarName tvs) -- | Checks that a list of type patterns is valid in a matching (LHS) -- position of a class instances or type/data family instance. @@ -2297,26 +2354,13 @@ -- Ensure that no type family applications occur a type pattern ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ty_fam_inst_illegal_err tf_is_invis_arg - (mkTyConApp tf_tc tf_args) } + ((tf_is_invis_arg, tf_tc, tf_args):_) -> + failWithTc $ TcRnIllegalInstance $ + IllegalFamilyApplicationInInstance inst_ty + tf_is_invis_arg tf_tc tf_args } where inst_ty = mkTyConApp tc pat_ty_args - ty_fam_inst_illegal_err :: Bool -> Type -> SDoc - ty_fam_inst_illegal_err invis_arg ty - = pprWithExplicitKindsWhen invis_arg $ - hang (text "Illegal type synonym family application" - <+> quotes (ppr ty) <+> text "in instance" <> colon) - 2 (ppr inst_ty) - --- Error messages - -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch fam_tc cur_branch - = text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranchUser fam_tc cur_branch) - ------------------------- checkConsistentFamInst :: AssocInstInfo -> TyCon -- ^ Family tycon @@ -2340,8 +2384,10 @@ -- Check that the associated type indeed comes from this class -- See [Mismatched class methods and associated type families] -- in TcInstDecls. - ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) - (TcRnBadAssociatedType (className clas) (tyConName fam_tc)) + ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + InvalidAssoc $ InvalidAssocInstance $ + AssocNotInThisClass clas fam_tc ; check_match arg_triples } @@ -2356,29 +2402,12 @@ ax_arg_tys , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] - pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ - vcat [ text "Type indexes must match class instance head" - , text "Expected:" <+> pp_expected_ty - , text " Actual:" <+> pp_actual_ty ] - -- Fiddling around to arrange that wildcards unconditionally print as "_" -- We only need to print the LHS, not the RHS at all -- See Note [Printing conflicts with class header] (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs) - pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - [ case lookupVarEnv mini_env at_tv of - Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty - Nothing -> mk_wildcard at_tv - | at_tv <- tyConTyVars fam_tc ] - - pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - tidyTypes tidy_env2 ax_arg_tys - mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan @@ -2393,8 +2422,18 @@ , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 = go lr_subst1 rl_subst1 triples | otherwise - = addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) + = addErrTc $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocTyVarsDontMatch vis fam_tc exp_tys act_tys + -- Expected/actual family argument types (for error messages) + exp_tys = + [ case lookupVarEnv mini_env at_tv of + Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty + Nothing -> mk_wildcard at_tv + | at_tv <- tyConTyVars fam_tc ] + act_tys = tidyTypes tidy_env2 ax_arg_tys + -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. no_bind_set = mkVarSet inst_tvs @@ -2821,19 +2860,12 @@ checkTyConTelescope tc | bad_scope = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") - 2 pp_tc_kind - , extra - , hang (text "Perhaps try this order instead:") - 2 (pprTyVars sorted_tvs) ] + addErr $ TcRnBadTyConTelescope tc | otherwise = return () where tcbs = tyConBinders tc - tvs = binderVars tcbs - sorted_tvs = scopedSort tvs (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs @@ -2844,34 +2876,3 @@ where tv = binderVar tcb fkvs = tyCoVarsOfType (tyVarKind tv) - - inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] - specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] - - pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) - pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) - - pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) - ppr_untidy ty = pprIfaceType (toIfaceType ty) - -- We need ppr_untidy here because pprType will tidy the type, which - -- will turn the bogus kind we are trying to report - -- T :: forall (a::k) k (b::k) -> blah - -- into a misleadingly sanitised version - -- T :: forall (a::k) k1 (b::k1) -> blah - - extra - | null inferred_tvs && null specified_tvs - = empty - | null inferred_tvs - = hang (text "NB: Specified variables") - 2 (sep [pp_spec, text "always come first"]) - | null specified_tvs - = hang (text "NB: Inferred variables") - 2 (sep [pp_inf, text "always come first"]) - | otherwise - = hang (text "NB: Inferred variables") - 2 (vcat [ sep [ pp_inf, text "always come first"] - , sep [text "then Specified variables", pp_spec]]) - diff --git a/compiler/GHC/Tc/Zonk/Env.hs b/compiler/GHC/Tc/Zonk/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Zonk/Env.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | The 'ZonkEnv' zonking environment, and the 'ZonkT' and 'ZonkBndrT' +-- monad transformers, for the final zonking to type in "GHC.Tc.Zonk.Type". +-- +-- See Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.Env + ( -- * The 'ZonkEnv' + ZonkEnv(..), getZonkEnv + , ZonkFlexi(..) + , initZonkEnv + + -- * The 'ZonkT' and 'ZonkBndrT' zonking monad transformers + , ZonkT(ZonkT,runZonkT), ZonkBndrT(..) + + -- ** Going between 'ZonkT' and 'ZonkBndrT' + , runZonkBndrT + , noBinders, don'tBind + + -- ** Modifying and extending the 'ZonkEnv' in 'ZonkBndrT' + , setZonkType + , extendZonkEnv + , extendIdZonkEnv, extendIdZonkEnvRec + , extendTyZonkEnv + + ) + where + +import GHC.Prelude + +import GHC.Core.TyCo.Rep ( Type ) +import GHC.Types.Var ( TyCoVar, Var, TyVar ) + +import GHC.Types.Var ( Id, isTyCoVar ) +import GHC.Types.Var.Env + +import GHC.Utils.Monad.Codensity +import GHC.Utils.Outputable + +import Control.Monad.Fix ( MonadFix(..) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Class ( MonadTrans(..) ) +import Data.Coerce ( coerce ) +import Data.IORef ( IORef, newIORef ) +import Data.List ( partition ) + +import GHC.Exts ( oneShot ) + +-------------------------------------------------------------------------------- + +-- | See Note [The ZonkEnv] +data ZonkEnv + = ZonkEnv { ze_flexi :: !ZonkFlexi + , ze_tv_env :: TyCoVarEnv TyCoVar + , ze_id_env :: IdEnv Id + , ze_meta_tv_env :: IORef (TyVarEnv Type) } + +-- | How should we handle unfilled unification variables in the zonker? +-- +-- See Note [Un-unified unification variables] +data ZonkFlexi + = DefaultFlexi -- ^ Default unbound unification variables to Any + | SkolemiseFlexi -- ^ Skolemise unbound unification variables + -- See Note [Zonking the LHS of a RULE] + | RuntimeUnkFlexi -- ^ Used in the GHCi debugger + | NoFlexi -- ^ Panic on unfilled meta-variables + -- See Note [Error on unconstrained meta-variables] + -- in GHC.Tc.Utils.TcMType + +instance Outputable ZonkEnv where + ppr (ZonkEnv { ze_tv_env = tv_env + , ze_id_env = id_env }) + = text "ZE" <+> braces (vcat + [ text "ze_tv_env =" <+> ppr tv_env + , text "ze_id_env =" <+> ppr id_env ]) + +{- Note [The ZonkEnv] +~~~~~~~~~~~~~~~~~~~~~ +* ze_flexi :: ZonkFlexi says what to do with a + unification variable that is still un-unified. + See Note [Un-unified unification variables] + +* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site + of a tyvar or covar, we zonk the kind right away and add a mapping + to the env. This prevents re-zonking the kind at every + occurrence. But this is *just* an optimisation. + +* ze_id_env : IdEnv Id promotes sharing among Ids, by making all + occurrences of the Id point to a single zonked copy, built at the + binding site. + + Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. + In a mutually recursive group + rec { f = ...g...; g = ...f... } + we want the occurrence of g to point to the one zonked Id for g, + and the same for f. + + Because it is knot-tied, we must be careful to consult it lazily. + +* ze_meta_tv_env: see Note [Sharing when zonking to Type] + + +Notes: + * We must be careful never to put coercion variables (which are Ids, + after all) in the knot-tied ze_id_env, because coercions can + appear in types, and we sometimes inspect a zonked type in + the GHC.Tc.Zonk.Type module. [Question: where, precisely?] + + * An obvious suggestion would be to have one VarEnv Var to + replace both ze_id_env and ze_tv_env, but that doesn't work + because of the knot-tying stuff mentioned above. + +Note [Un-unified unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if we find a Flexi unification variable? +There are three possibilities: + +* DefaultFlexi: this is the common case, in situations like + length @alpha ([] @alpha) + It really doesn't matter what type we choose for alpha. But + we must choose a type! We can't leave mutable unification + variables floating around: after typecheck is complete, every + type variable occurrence must have a binding site. + + So we default it to 'Any' of the right kind. + + All this works for both type and kind variables (indeed + the two are the same thing). + +* SkolemiseFlexi: is a special case for the LHS of RULES. + See Note [Zonking the LHS of a RULE] + +* RuntimeUnkFlexi: is a special case for the GHCi debugger. + It's a way to have a variable that is not a mutable + unification variable, but doesn't have a binding site + either. + +* NoFlexi: See Note [Error on unconstrained meta-variables] + in GHC.Tc.Utils.TcMType. This mode will panic on unfilled + meta-variables. +-} + +-- | A reader monad over 'ZonkEnv', for zonking computations which +-- don't modify the 'ZonkEnv' (e.g. don't bind any variables). +-- +-- Use 'ZonkBndrT' when you need to modify the 'ZonkEnv' (e.g. to bind +-- a variable). +newtype ZonkT m a = ZonkT' { runZonkT :: ZonkEnv -> m a } + +{- Note [Instances for ZonkT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Below, we derive the following instances by hand: + + newtype ZonkT m a = ZonkT { runZonkT :: ZonkEnv -> m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + via ReaderT ZonkEnv m + deriving MonadTrans + via ReaderT ZonkEnv + +Why? Two reasons: + + 1. To use oneShot. See Note [The one-shot state monad trick] in GHC.Utils.Monad. + 2. To be strict in the ZonkEnv. This allows us to worker-wrapper functions, + passing them individual fields of the ZonkEnv instead of the whole record. + When this happens, we avoid allocating a ZonkEnv, which is a win. +-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE ZonkT #-} +pattern ZonkT :: forall m a. (ZonkEnv -> m a) -> ZonkT m a +pattern ZonkT m <- ZonkT' m + where + ZonkT m = ZonkT' (oneShot m) + +-- See Note [Instances for ZonkT] +instance Functor m => Functor (ZonkT m) where + fmap f (ZonkT g) = ZonkT $ \ !env -> fmap f (g env) + a <$ ZonkT g = ZonkT $ \ !env -> a <$ g env + {-# INLINE fmap #-} + {-# INLINE (<$) #-} + +-- See Note [Instances for ZonkT] +instance Applicative m => Applicative (ZonkT m) where + pure a = ZonkT (\ !_ -> pure a) + ZonkT f <*> ZonkT x = ZonkT (\ !env -> f env <*> x env ) + ZonkT m *> f = ZonkT (\ !env -> m env *> runZonkT f env) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + +-- See Note [Instances for ZonkT] +instance Monad m => Monad (ZonkT m) where + ZonkT m >>= f = + ZonkT (\ !env -> do { r <- m env + ; runZonkT (f r) env }) + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} + +-- See Note [Instances for ZonkT] +instance MonadIO m => MonadIO (ZonkT m) where + liftIO f = ZonkT (\ !_ -> liftIO f) + {-# INLINE liftIO #-} + +-- See Note [Instances for ZonkT] +instance MonadTrans ZonkT where + lift ma = ZonkT $ \ !_ -> ma + {-# INLINE lift #-} + +-- See Note [Instances for ZonkT] +instance MonadFix m => MonadFix (ZonkT m) where + mfix f = ZonkT $ \ !r -> mfix $ oneShot $ \ a -> runZonkT (f a) r + {-# INLINE mfix #-} + +-- | Zonk binders, bringing them into scope in the inner computation. +-- +-- Can be thought of as a state monad transformer @StateT ZonkEnv m a@, +-- but written in continuation-passing style. +-- +-- See Note [Continuation-passing style for zonking]. +newtype ZonkBndrT m a = ZonkBndrT { runZonkBndrT' :: forall r. (a -> ZonkT m r) -> ZonkT m r } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + via Codensity (ZonkT m) + -- See GHC.Utils.Monad.Codensity for the instance definitions. + -- See Note [Continuation-passing style for zonking] for why we use + -- continuation-passing style instead of a direct state monad. + +{- Note [Continuation-passing style for zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While zonking, we sometimes need to modify the ZonkEnv. For example, when +zonking a binder with zonkTyBndrX, we extend the type variable ZonkEnv. + +We could use direct state passing: + + zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) + zonkTyBndrX ze tv = + do { tv' <- ... ze tv + ; let ze' = extendTyZonkEnv ze tv' + ; return (ze', tv') } + +but we can avoid allocating pairs by using continuation-passing style instead, +for example: + + zonkTyBndrX :: (ZonkEnv -> TcTyVar -> TcM r) -> ZonkEnv -> TcM r + zonkTyBndrX k ze = + do { tv' <- ... ze tv + ; let ze' = extendTyZonkEnv ze tv + ; k ze' tv' } + +We thus define: + + newtype ZonkBndrT m a = + ZonkBndrT { runZonkBndrT :: forall r. (a -> ZonkT m r) -> ZonkT m r } + +which is the type of continuation-passing computations over ZonkT m = ReaderT ZonkEnv m. +We thus have: + + zonkTyBndrX :: TcTyVar -> ZonkBndrT TcM TyVar + +which expresses the fact that zonkTyBndrX takes in a TcTyVar, returns a TyVar, +modifying the ZonkEnv state in the process. We can build computations out of it +by using runZonkBndrT and nesting. For example, zonking a type synonym: + + zonkTySynRHS :: [TcTyConBinder] -> [TcTyVar] -> ZonkT TcM ([TyConBinder], [TyVar]) + zonkTySynRHS tc_bndrs rhs_tc_ty = + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { rhs_ty <- zonkTcTypeToTypeX rhs_tc_ty + ; return (bndrs, rhs_ty) } + +This is known as the codensity transformation, where + + newtype Codensity m a = Codensity { forall r. (a -> m r) -> m r } + +expresses continuation-passing computations in the monad m. + +Codensity (ReaderT s m) naturally corresponds to StateT s (Codensity m), and +the instances for Codensity reflect that, e.g. + + traverse :: (a -> ZonkBndrT m b) -> t a -> ZonkBndrT m (t b) + +naturally behaves like mapAccumLM, accumulating changes to the ZonkEnv as +we go. +-} + +-- | Zonk some binders and run the continuation. +-- +-- Example: +-- +-- > zonk (ForAllTy (Bndr tv vis) body_ty) +-- > = runZonkBndrT (zonkTyBndrX tv) $ \ tv' -> +-- > do { body_ty' <- zonkTcTypeToTypeX body_ty +-- > ; return (ForAllTy (Bndr tv' vis) body_ty') } +-- +-- See Note [Continuation-passing style for zonking]. +runZonkBndrT :: ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r +runZonkBndrT (ZonkBndrT k) f = k (oneShot f) +{-# INLINE runZonkBndrT #-} + +-- | Embed a computation that doesn't modify the 'ZonkEnv' into 'ZonkBndrT'. +noBinders :: Monad m => ZonkT m a -> ZonkBndrT m a +noBinders z = coerce $ toCodensity z +{-# INLINE noBinders #-} + +-- | Run a nested computation that modifies the 'ZonkEnv', +-- without affecting the outer environment. +don'tBind :: Monad m => ZonkBndrT m a -> ZonkT m a +don'tBind (ZonkBndrT k) = fromCodensity (Codensity k) +{-# INLINE don'tBind #-} + +initZonkEnv :: MonadIO m => ZonkFlexi -> ZonkT m b -> m b +initZonkEnv flexi thing_inside + = do { mtv_env_ref <- liftIO $ newIORef emptyVarEnv + ; let ze = ZonkEnv { ze_flexi = flexi + , ze_tv_env = emptyVarEnv + , ze_id_env = emptyVarEnv + , ze_meta_tv_env = mtv_env_ref } + + ; runZonkT thing_inside ze } +{-# INLINEABLE initZonkEnv #-} -- so it can be specialised + +nestZonkEnv :: (ZonkEnv -> ZonkEnv) -> ZonkBndrT m () +nestZonkEnv f = ZonkBndrT $ \ k -> + case k () of + ZonkT g -> ZonkT (g . f) +{-# INLINE nestZonkEnv #-} + +getZonkEnv :: Monad m => ZonkT m ZonkEnv +getZonkEnv = ZonkT return +{-# INLINE getZonkEnv #-} + +-- | Extend the knot-tied environment. +extendIdZonkEnvRec :: [Var] -> ZonkBndrT m () +extendIdZonkEnvRec ids = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_id_env = id_env }) -> + -- NB: Don't look at the var to decide which env't to put it in. That + -- would end up knot-tying all the env'ts. + ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + -- Given coercion variables will actually end up here. That's OK though: + -- coercion variables are never looked up in the knot-tied env't, so zonking + -- them simply doesn't get optimised. No one gets hurt. An improvement (?) + -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the + -- recursive groups. But perhaps the time it takes to do the analysis is + -- more than the savings. + +extendZonkEnv :: [Var] -> ZonkBndrT m () +extendZonkEnv vars = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) -> + ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] + , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + where + (tycovars, ids) = partition isTyCoVar vars + +extendIdZonkEnv :: Var -> ZonkBndrT m () +extendIdZonkEnv id = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_id_env = id_env }) -> + ze { ze_id_env = extendVarEnv id_env id id } + +extendTyZonkEnv :: TyVar -> ZonkBndrT m () +extendTyZonkEnv tv = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_tv_env = ty_env }) -> + ze { ze_tv_env = extendVarEnv ty_env tv tv } + +setZonkType :: ZonkFlexi -> ZonkT m a -> ZonkT m a +setZonkType flexi (ZonkT f) = ZonkT $ \ ze -> + f $ ze { ze_flexi = flexi } diff --git a/compiler/GHC/Tc/Zonk/TcType.hs b/compiler/GHC/Tc/Zonk/TcType.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Zonk/TcType.hs @@ -0,0 +1,680 @@ + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 +-} + +-- | Zonking types within the typechecker. +-- +-- Distinct from the final zonking pass in "GHC.Tc.Zonk.Type"; +-- see Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.TcType + ( -- * Zonking (within the typechecker) + + -- ** The 'ZonkM' monad and 'ZonkGblEnv' + module GHC.Tc.Zonk.Monad + + -- ** Zonking types + , zonkTcType, zonkTcTypes + , zonkTcTyVar, zonkTcTyVars + , zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars + , zonkInvisTVBinder + , zonkCo + + -- ** Zonking 'TyCon's + , zonkTcTyCon + + -- *** FreeVars + , zonkTcTypeAndFV, zonkTyCoVarsAndFV, zonkTyCoVarsAndFVList + , zonkDTyCoVarSetAndFV + + -- ** Zonking 'CoVar's and 'Id's + , zonkId, zonkCoVar, zonkTyCoVar, zonkTyCoVarKind, zonkTyCoVarBndrKind + + -- ** Zonking skolem info + , zonkSkolemInfo, zonkSkolemInfoAnon + + -- ** Zonking constraints + , zonkCt, zonkWC, zonkSimples, zonkImplication + + -- * Tidying + , tcInitTidyEnv, tcInitOpenTidyEnv + , tidyCt, tidyEvVar, tidyDelayedError + + -- ** Zonk & tidy + , zonkTidyTcType, zonkTidyTcTypes + , zonkTidyOrigin, zonkTidyOrigins + , zonkTidyFRRInfos + + -- * Writing to metavariables + , writeMetaTyVar, writeMetaTyVarRef + + -- * Handling coercion holes + , checkCoercionHole + + ) + where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set + +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Monad + +import GHC.Core.InstEnv (ClsInst(is_tys)) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Predicate + +import GHC.Utils.Constants +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Panic + +import GHC.Data.Bag +import GHC.Data.Pair + +{- ********************************************************************* +* * + Writing to metavariables +* * +************************************************************************ +-} + +-- | Write into a currently-empty MetaTyVar. +-- +-- Works with both type and kind variables. +writeMetaTyVar :: HasDebugCallStack + => TcTyVar -- ^ the type varfiable to write to + -> TcType -- ^ the type to write into the mutable reference + -> ZonkM () +writeMetaTyVar tyvar ty + | not debugIsOn + = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty + +-- Everything from here on only happens if DEBUG is on + | not (isTcTyVar tyvar) + = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar) + + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar + = writeMetaTyVarRef tyvar ref ty + + | otherwise + = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) +{-# INLINE writeMetaTyVar #-} -- See NOTE [Inlining writeMetaTyVar] + +-- | Write into the 'MetaDetails' mutable references of a 'MetaTv'. +writeMetaTyVarRef :: HasDebugCallStack + => TcTyVar -- ^ for debug assertions only; + -> TcRef MetaDetails -- ^ ref cell must be for the same tyvar + -> TcType -- ^ the type to write to the mutable reference + -> ZonkM () +writeMetaTyVarRef tyvar ref ty + | not debugIsOn + = do { traceZonk "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) + <+> text ":=" <+> ppr ty) + ; writeTcRef ref (Indirect ty) } + + -- Everything from here on only happens if DEBUG is on + -- Need to zonk 'ty' because we may only recently have promoted + -- its free meta-tyvars (see GHC.Tc.Utils.Unify.checkPromoteFreeVars) + | otherwise + = do { meta_details <- readTcRef ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcType tv_kind + ; zonked_ty <- zonkTcType ty + ; let zonked_ty_kind = typeKind zonked_ty + zonked_ty_lvl = tcTypeLevel zonked_ty + level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) + level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty $$ ppr zonked_ty + kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind + -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType + + kind_msg = hang (text "Ill-kinded update to meta tyvar") + 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) + <+> text ":=" + <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) + + ; traceZonk "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) + + -- Check for double updates + ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details) + + -- Check for level OK + ; massertPpr level_check_ok level_check_msg + + -- Check Kinds ok + ; massertPpr kind_check_ok kind_msg + + -- Do the write + ; writeTcRef ref (Indirect ty) } + where + tv_kind = tyVarKind tyvar + + tv_lvl = tcTyVarLevel tyvar + + + double_upd_msg details = hang (text "Double update of meta tyvar") + 2 (ppr tyvar $$ ppr details) +{-# INLINE writeMetaTyVarRef #-} -- See NOTE [Inlining writeMetaTyVar] + +{- NOTE [Inlining writeMetaTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +writeMetaTyVar is defined in the ZonkM monad, but it is often used within +TcM with the following idiom: + + liftZonkM $ writeMetaTyVar tv ty + +Using liftZonkM within TcM generally means extracting out a ZonkGblEnv +from the TcM monad to pass to the inner ZonkM computation (see the definition +of liftZonkM). This can cause writeMetaTyVar to allocate a ZonkGblEnv, which we +would much rather avoid! +Instead, we should directly pass the bits of the ZonkGblEnv that writeMetaTyVar +needs (the Logger and NamePprCtxt, which are needed for the traceZonk call +in writeMetaTyVar). This is achieved by inlining writeMetaTyVar and writeMetaTyVarRef. +These functions just wrap writeTcRef, with some extra tracing +(and some assertions if running in debug mode), so it's fine to inline them. + +See for example test T5631, which regresses without this change. +-} + +{- +************************************************************************ +* * + Zonking -- the main work-horses: zonkTcType, zonkTcTyVar +* * +************************************************************************ +-} + +-- For unbound, mutable tyvars, zonkType uses the function given to it +-- For tyvars bound at a for-all, zonkType zonks them to an immutable +-- type variable and zonks the kind too +zonkTcType :: TcType -> ZonkM TcType +zonkTcTypes :: [TcType] -> ZonkM [TcType] +zonkCo :: Coercion -> ZonkM Coercion +(zonkTcType, zonkTcTypes, zonkCo, _) + = mapTyCo zonkTcTypeMapper + +-- | A suitable TyCoMapper for zonking a type during type-checking, +-- before all metavars are filled in. +zonkTcTypeMapper :: TyCoMapper () ZonkM +zonkTcTypeMapper = TyCoMapper + { tcm_tyvar = const zonkTcTyVar + , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) + , tcm_hole = hole + , tcm_tycobinder = \ _env tcv _vis k -> zonkTyCoVarKind tcv >>= k () + , tcm_tycon = zonkTcTyCon } + where + hole :: () -> CoercionHole -> ZonkM Coercion + hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCo co + ; checkCoercionHole cv co' } + Nothing -> do { cv' <- zonkCoVar cv + ; return $ HoleCo (hole { ch_co_var = cv' }) } } + +zonkTcTyCon :: TcTyCon -> ZonkM TcTyCon +-- Only called on TcTyCons +-- A non-poly TcTyCon may have unification +-- variables that need zonking, but poly ones cannot +zonkTcTyCon tc + | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc) + ; return (setTcTyConKind tc tck') } + | otherwise = return tc + +zonkTcTyVar :: TcTyVar -> ZonkM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> do { zty <- zonkTcType ty + ; writeTcRef ref (Indirect zty) + -- See Note [Sharing in zonking] + ; return zty } } + + | otherwise -- coercion variable + = zonk_kind_and_return + where + zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv + ; return (mkTyVarTy z_tv) } + +-- Variant that assumes that any result of zonking is still a TyVar. +-- Should be used only on skolems and TyVarTvs +zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> ZonkM [TcTyVar] +zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar + +zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> ZonkM TcTyVar +zonkTcTyVarToTcTyVar tv + = do { ty <- zonkTcTyVar tv + ; let tv' = case getTyVar_maybe ty of + Just tv' -> tv' + Nothing -> pprPanic "zonkTcTyVarToTcTyVar" + (ppr tv $$ ppr ty) + ; return tv' } + +zonkInvisTVBinder :: VarBndr TcTyVar spec -> ZonkM (VarBndr TcTyVar spec) +zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv + ; return (Bndr tv' spec) } + +{- ********************************************************************* +* * + Zonking types +* * +********************************************************************* -} + +zonkTcTypeAndFV :: TcType -> ZonkM DTyCoVarSet +-- Zonk a type and take its free variables +-- With kind polymorphism it can be essential to zonk *first* +-- so that we find the right set of free variables. Eg +-- forall k1. forall (a:k2). a +-- where k2:=k1 is in the substitution. We don't want +-- k2 to look free in this type! +zonkTcTypeAndFV ty + = tyCoVarsOfTypeDSet <$> zonkTcType ty + +zonkTyCoVar :: TyCoVar -> ZonkM TcType +-- Works on TyVars and TcTyVars +zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv + | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv + | otherwise = assertPpr (isCoVar tv) (ppr tv) $ + mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv + -- Hackily, when typechecking type and class decls + -- we have TyVars in scope added (only) in + -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyCoVarsAndFV :: TyCoVarSet -> ZonkM TyCoVarSet +zonkTyCoVarsAndFV tycovars + = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) + -- It's OK to use nonDetEltsUniqSet here because we immediately forget about + -- the ordering by turning it into a nondeterministic set and the order + -- of zonking doesn't matter for determinism. + +zonkDTyCoVarSetAndFV :: DTyCoVarSet -> ZonkM DTyCoVarSet +zonkDTyCoVarSetAndFV tycovars + = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) + +-- Takes a list of TyCoVars, zonks them and returns a +-- deterministically ordered list of their free variables. +zonkTyCoVarsAndFVList :: [TyCoVar] -> ZonkM [TyCoVar] +zonkTyCoVarsAndFVList tycovars + = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars + +zonkTcTyVars :: [TcTyVar] -> ZonkM [TcType] +zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars + +----------------- Types +zonkTyCoVarKind :: TyCoVar -> ZonkM TyCoVar +zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind') } + +zonkTyCoVarBndrKind :: VarBndr TyCoVar flag -> ZonkM (VarBndr TyCoVar flag) +zonkTyCoVarBndrKind (Bndr tv flag) = + do { tv' <- zonkTyCoVarKind tv + ; return (Bndr tv' flag) } + +-- | zonkId is used *during* typechecking just to zonk the 'Id''s type +zonkId :: TcId -> ZonkM TcId +zonkId id = updateIdTypeAndMultM zonkTcType id + +zonkCoVar :: CoVar -> ZonkM CoVar +zonkCoVar = zonkId + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +-- | Check that a coercion is appropriate for filling a hole. (The hole +-- itself is needed only for printing.) +-- Always returns the checked coercion, but this return value is necessary +-- so that the input coercion is forced only when the output is forced. +checkCoercionHole :: CoVar -> Coercion -> ZonkM Coercion +checkCoercionHole cv co + | debugIsOn + = do { cv_ty <- zonkTcType (varType cv) + -- co is already zonked, but cv might not be + ; return $ + assertPpr (ok cv_ty) + (text "Bad coercion hole" <+> + ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role + , ppr cv_ty ]) + co } + | otherwise + = return co + + where + (Pair t1 t2, role) = coercionKindRole co + ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty + = t1 `eqType` cv_t1 + && t2 `eqType` cv_t2 + && role == eqRelRole cv_rel + | otherwise + = False + + +{- +************************************************************************ +* * + Zonking constraints +* * +************************************************************************ +-} + +zonkImplication :: Implication -> ZonkM Implication +zonkImplication implic@(Implic { ic_skols = skols + , ic_given = given + , ic_wanted = wanted + , ic_info = info }) + = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! + -- as #7230 showed + ; given' <- mapM zonkEvVar given + ; info' <- zonkSkolemInfoAnon info + ; wanted' <- zonkWCRec wanted + ; return (implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' }) } + +zonkEvVar :: EvVar -> ZonkM EvVar +zonkEvVar var = updateIdTypeAndMultM zonkTcType var + + +zonkWC :: WantedConstraints -> ZonkM WantedConstraints +zonkWC wc = zonkWCRec wc + +zonkWCRec :: WantedConstraints -> ZonkM WantedConstraints +zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs }) + = do { simple' <- zonkSimples simple + ; implic' <- mapBagM zonkImplication implic + ; errs' <- mapBagM zonkDelayedError errs + ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) } + +zonkSimples :: Cts -> ZonkM Cts +zonkSimples cts = do { cts' <- mapBagM zonkCt cts + ; traceZonk "zonkSimples done:" (ppr cts') + ; return cts' } + +zonkDelayedError :: DelayedError -> ZonkM DelayedError +zonkDelayedError (DE_Hole hole) + = DE_Hole <$> zonkHole hole +zonkDelayedError (DE_NotConcrete err) + = DE_NotConcrete <$> zonkNotConcreteError err + +zonkHole :: Hole -> ZonkM Hole +zonkHole hole@(Hole { hole_ty = ty }) + = do { ty' <- zonkTcType ty + ; return (hole { hole_ty = ty' }) } + +zonkNotConcreteError :: NotConcreteError -> ZonkM NotConcreteError +zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig }) + = do { frr_orig <- zonkFRROrigin frr_orig + ; return $ err { nce_frr_origin = frr_orig } } + +zonkFRROrigin :: FixedRuntimeRepOrigin -> ZonkM FixedRuntimeRepOrigin +zonkFRROrigin (FixedRuntimeRepOrigin ty orig) + = do { ty' <- zonkTcType ty + ; return $ FixedRuntimeRepOrigin ty' orig } + +{- Note [zonkCt behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +zonkCt tries to maintain the canonical form of a Ct. For example, + - a CDictCan should stay a CDictCan; + - a CIrredCan should stay a CIrredCan with its cc_reason flag intact + +Why?, for example: +- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the + simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, + constraints are zonked before being passed to the plugin. This means if we + don't preserve a canonical form, @expandSuperClasses@ fails to expand + superclasses. This is what happened in #11525. + +- For CIrredCan we want to see if a constraint is insoluble with insolubleWC + +On the other hand, we change CEqCan to CNonCanonical, because of all of +CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where +we have alpha := N Int, where N is a newtype.) Besides, the constraint +will be canonicalised again, so there is little benefit in keeping the +CEqCan structure. + +NB: Constraints are always rewritten etc by the canonicaliser in +GHC.Tc.Solver.Solve.solveCt even if they come in as CDictCan. Only canonical +constraints that are actually in the inert set carry all the guarantees. So it +is okay if zonkCt creates e.g. a CDictCan where the cc_tyars are /not/ fully +reduced. +-} + +zonkCt :: Ct -> ZonkM Ct +-- See Note [zonkCt behaviour] +zonkCt (CDictCan dict@(DictCt { di_ev = ev, di_tys = args })) + = do { ev' <- zonkCtEvidence ev + ; args' <- mapM zonkTcType args + ; return (CDictCan (dict { di_ev = ev', di_tys = args' })) } + +zonkCt (CEqCan (EqCt { eq_ev = ev })) + = mkNonCanonical <$> zonkCtEvidence ev + +zonkCt (CIrredCan ir@(IrredCt { ir_ev = ev })) -- Preserve the ir_reason flag + = do { ev' <- zonkCtEvidence ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + +zonkCt ct + = do { fl' <- zonkCtEvidence (ctEvidence ct) + ; return (mkNonCanonical fl') } + +zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence +zonkCtEvidence ctev + = do { let pred = ctev_pred ctev + ; pred' <- zonkTcType pred + ; return (setCtEvPredType ctev pred') } + +zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo +zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk + +zonkSkolemInfoAnon :: SkolemInfoAnon -> ZonkM SkolemInfoAnon +zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty' tv_prs) } +zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } + where + do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } +zonkSkolemInfoAnon skol_info = return skol_info + +{- Note [Sharing in zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + alpha :-> beta :-> gamma :-> ty +where the ":->" means that the unification variable has been +filled in with Indirect. Then when zonking alpha, it'd be nice +to short-circuit beta too, so we end up with + alpha :-> zty + beta :-> zty + gamma :-> zty +where zty is the zonked version of ty. That way, if we come across +beta later, we'll have less work to do. (And indeed the same for +alpha.) + +This is easily achieved: just overwrite (Indirect ty) with (Indirect +zty). Non-systematic perf comparisons suggest that this is a modest +win. + +But c.f Note [Sharing when zonking to Type] in GHC.Tc.Zonk.Type. + +%************************************************************************ +%* * + Tidying +* * +************************************************************************ +-} + +tcInitTidyEnv :: ZonkM TidyEnv +-- We initialise the "tidy-env", used for tidying types before printing, +-- by building a reverse map from the in-scope type variables to the +-- OccName that the programmer originally used for them +tcInitTidyEnv + = do { ZonkGblEnv { zge_binder_stack = bndrs } <- getZonkGblEnv + ; go emptyTidyEnv bndrs } + where + go (env, subst) [] + = return (env, subst) + go (env, subst) (b : bs) + | TcTvBndr name tyvar <- b + = do { let (env', occ') = tidyOccName env (nameOccName name) + name' = tidyNameOcc name occ' + tyvar1 = setTyVarName tyvar name' + ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 + -- Be sure to zonk here! Tidying applies to zonked + -- types, so if we don't zonk we may create an + -- ill-kinded type (#14175) + ; go (env', extendVarEnv subst tyvar tyvar2) bs } + | otherwise + = go (env, subst) bs + +-- | Get a 'TidyEnv' that includes mappings for all vars free in the given +-- type. Useful when tidying open types. +tcInitOpenTidyEnv :: [TyCoVar] -> ZonkM TidyEnv +tcInitOpenTidyEnv tvs + = do { env1 <- tcInitTidyEnv + ; let env2 = tidyFreeTyCoVars env1 tvs + ; return env2 } + +zonkTidyTcType :: TidyEnv -> TcType -> ZonkM (TidyEnv, TcType) +zonkTidyTcType env ty = do { ty' <- zonkTcType ty + ; return (tidyOpenType env ty') } + +zonkTidyTcTypes :: TidyEnv -> [TcType] -> ZonkM (TidyEnv, [TcType]) +zonkTidyTcTypes = zonkTidyTcTypes' [] + where zonkTidyTcTypes' zs env [] = return (env, reverse zs) + zonkTidyTcTypes' zs env (ty:tys) + = do { (env', ty') <- zonkTidyTcType env ty + ; zonkTidyTcTypes' (ty':zs) env' tys } + +zonkTidyOrigin :: TidyEnv -> CtOrigin -> ZonkM (TidyEnv, CtOrigin) +zonkTidyOrigin env (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 + ; return (env, GivenOrigin skol_info2) } +zonkTidyOrigin env (GivenSCOrigin skol_info sc_depth blocked) + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 + ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) } +zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act + , uo_expected = exp }) + = do { (env1, act') <- zonkTidyTcType env act + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( env2, orig { uo_actual = act' + , uo_expected = exp' }) } +zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } +zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, o1') <- zonkTidyOrigin env1 o1 + ; (env3, p2') <- zonkTidyTcType env2 p2 + ; (env4, o2') <- zonkTidyOrigin env3 o2 + ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } +zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; (env3, o1') <- zonkTidyOrigin env2 o1 + ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = do { (env1, pred1') <- zonkTidyTcType env pred1 + ; (env2, orig1') <- zonkTidyOrigin env1 orig1 + ; (env3, pred2') <- zonkTidyTcType env2 pred2 + ; (env4, orig2') <- zonkTidyOrigin env3 orig2 + ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } +zonkTidyOrigin env (CycleBreakerOrigin orig) + = do { (env1, orig') <- zonkTidyOrigin env orig + ; return (env1, CycleBreakerOrigin orig') } +zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) + = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst) + ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) } +zonkTidyOrigin env (WantedSuperclassOrigin pty orig) + = do { (env1, pty') <- zonkTidyTcType env pty + ; (env2, orig') <- zonkTidyOrigin env1 orig + ; return (env2, WantedSuperclassOrigin pty' orig') } +zonkTidyOrigin env orig = return (env, orig) + +zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> ZonkM (TidyEnv, [CtOrigin]) +zonkTidyOrigins = mapAccumLM zonkTidyOrigin + +zonkTidyFRRInfos :: TidyEnv + -> [FixedRuntimeRepErrorInfo] + -> ZonkM (TidyEnv, [FixedRuntimeRepErrorInfo]) +zonkTidyFRRInfos = go [] + where + go zs env [] = return (env, reverse zs) + go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig + , frr_info_not_concrete = mb_not_conc } : tys) + = do { (env, ty) <- zonkTidyTcType env ty + ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc + ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig + , frr_info_not_concrete = mb_not_conc } + ; go (info:zs) env tys } + + go_mb_not_conc env Nothing = return (env, Nothing) + go_mb_not_conc env (Just (tv, ty)) + = do { (env, tv) <- return $ tidyOpenTyCoVar env tv + ; (env, ty) <- zonkTidyTcType env ty + ; return (env, Just (tv, ty)) } + +---------------- +tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting +tidyCt env = updCtEvidence (tidyCtEvidence env) + +tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence + -- NB: we do not tidy the ctev_evar field because we don't + -- show it in error messages +tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty } + where + ty = ctev_pred ctev + +tidyHole :: TidyEnv -> Hole -> Hole +tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } + +tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError +tidyDelayedError env (DE_Hole hole) + = DE_Hole $ tidyHole env hole +tidyDelayedError env (DE_NotConcrete err) + = DE_NotConcrete $ tidyConcreteError env err + +tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError +tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig }) + = err { nce_frr_origin = tidyFRROrigin env frr_orig } + +tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin +tidyFRROrigin env (FixedRuntimeRepOrigin ty orig) + = FixedRuntimeRepOrigin (tidyType env ty) orig + +---------------- +tidyEvVar :: TidyEnv -> EvVar -> EvVar +tidyEvVar env var = updateIdTypeAndMult (tidyType env) var diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Zonk/Type.hs @@ -0,0 +1,1958 @@ +{-# LANGUAGE GADTs #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 +-} + +-- | Final zonking to 'Type'. See Note [Zonking to Type]. +-- +-- Distinct from the intra-typechecker zonking in "GHC.Tc.Zonk.TcType"; +-- see Note [Module structure for zonking]. +module GHC.Tc.Zonk.Type ( + -- * Zonking + -- | For a description of "zonking", see Note [What is zonking?]. + ZonkTcM, + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, + zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyBndrsX, + zonkTcTypeToType, zonkTcTypeToTypeX, + zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, + zonkTyVarOcc, + zonkCoToCo, + zonkEvBinds, zonkTcEvBinds, + zonkTcMethInfoToMethInfoX, + lookupTyVarX, + + -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers + module GHC.Tc.Zonk.Env, + + -- * Coercion holes + isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe, + + -- * Rewriter sets + zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet, + + -- * Tidying + tcInitTidyEnv, tcInitOpenTidyEnv, + + + ) where + +import GHC.Prelude + +import GHC.Builtin.Types + +import GHC.Core.TyCo.Ppr ( pprTyVar ) + +import GHC.Hs + +import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.TcRef +import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) +import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad ( setSrcSpanA, liftZonkM, traceTc, addErr ) +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.Env +-- Very little shared code between GHC.Tc.Zonk.TcType and GHC.Tc.Zonk.Type. +-- See Note [Module structure for zonking] +import GHC.Tc.Zonk.TcType + ( tcInitTidyEnv, tcInitOpenTidyEnv + , writeMetaTyVarRef + , checkCoercionHole + , zonkCoVar ) + +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCon + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain + +import GHC.Core.Multiplicity +import GHC.Core +import GHC.Core.Predicate + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.TypeEnv +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.TyThing + +import GHC.Tc.Types.BasicTypes + +import GHC.Data.Maybe +import GHC.Data.Bag + +import Control.Monad +import Control.Monad.Trans.Class ( lift ) +import Data.Semigroup + +{- Note [What is zonking?] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC relies heavily on mutability in the typechecker for efficient operation. +For this reason, throughout much of the type checking process, meta type +variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable +variables (known as TcRefs). + +Zonking is the process of replacing each such mutable variable with a Type. +This involves traversing the entire type expression, but the interesting part, +replacing the mutable variables, occurs in zonkTyVarOcc. + +There are two ways to zonk a Type, using one of two entirely separate zonkers, +that share essentially no code: + +* GHC.Tc.Zonk.TcType.zonkTcType, which is used /during/ type checking: + * It leaves unfilled metavars untouched, so the resulting Type can contain TcTyVars + * It is only defined for Type and Coercion, not for HsExpr + * It works in a very stripped-down monad, ZonkM, make it clear that it uses + very few effects (for example, it can't throw errors). + +* GHC.Tc.Zonk.Type.zonkTcTypeToType, is used /after/ typechecking is complete: + * It always returns a Type with no remaining TcTyVars; no meta-tyvars remain. + * It does defaulting, replacing an unconstrained TcTyVar with Any, or failing + (determined by the ZonkFlexi parameter used; see GHC.Tc.Zonk.Type.commitFlexi). + * It works over HsExpr and HsBinds as well as Type and Coercion. As part of this, + it also removes the mutable variables in evidence bindings. + * It works in the full TcM monad, augmented with an environment. + More precisely, it uses ZonkTcM and ZonkBndrTcM, which augment TcM with a + ZonkEnv environment using the zonking monad transformers ZonkT and ZonkBndrT + (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env). + + Why TcM rather than a smaller monad? See Note [Using TcM for zonking to Type]. + +Note [Module structure for zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As remarked in Note [What is zonking?], there are really two different zonkers; +we have GHC.Tc.Zonk.TcType for zonking within the typechecker and +GHC.Tc.Zonk.Type for the final zonking pass. + +The code relating to zonking is thus split up across the following modules: + + I. Zonking within the typechecker + 1. GHC.Tc.Zonk.Monad + 2. GHC.Tc.Zonk.TcType + + II. Final zonking to Type + 1. GHC.Tc.Zonk.Env + 2. GHC.Tc.Zonk.Type + +I.1. GHC.Tc.Zonk.Monad - the ZonkM monad + + GHC.Tc.Zonk.Monad defines the ZonkM monad, which is a stripped down version + of TcM which has just enough information to be able to zonk types. + + This is the monad used for zonking inside the typechecker, + as used in GHC.Tc.Zonk.TcType. + + Crucially, it never errors. It is the monad we use when reporting errors + (see ErrCtxt), and it would be quite bad if we could error in the middle + of reporting an error! + +I.2. GHC.Tc.Zonk.TcType - zonking types in the typechecker + + GHC.Tc.Zonk.TcType contains code for zonking types and constraints, for use + within the typechecker. It uses the ZonkM monad. + For example, it defines: + + zonkTcType :: TcType -> ZonkM TcType + zonkCt :: Ct -> ZonkM Ct + +II.1. GHC.Tc.Zonk.Env - the ZonkEnv and ZonkT/ZonkBndrT monad transformers + + GHC.Tc.Zonk.Env defines the the ZonkT and ZonkBndrT monad transformers. + These are essentially "ReaderT ZonkEnv" and "StateT ZonkEnv", except + that ZonkBndrT use continuation-passing style instead of an explicit state. + See Note [The ZonkEnv] in GHC.Tc.Zonk.Env. + + These are used for the final zonking to type, in GHC.Tc.Zonk.Type. + +II.2. GHC.Tc.Zonk.Type - final zonking to type + + GHC.Tc.Zonk.Type is concerned with the "final zonking" pass, after we finish + typechecking. It zonks not only types, but terms. It uses the monads + + type ZonkTcM = ZonkT TcM + type ZonkBndrTcM = ZonkBndrTcM + + for example: + + zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar + zonkTcTypeToTypeX :: TcType -> ZonkT TcM Type + +Note that ZonkTcM does a lot more things than ZonkM: + + - it uses a separate ZonkEnv state to accumulate zonked type + (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env) + - it defaults type variables, + (see Note [Un-unified unification variables] in GHC.Tc.Zonk.Env) + - turns TcTyVars into TyVars, + - ... + +This means that there is essentially no code shared between "GHC.Tc.Zonk.TcType" +and "GHC.Tc.Zonk.Type'; they're really two different zonkers. + +Note [Zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~ +Zonking to Type is a final zonking pass done *after* typechecking. +It runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void + c) convert each TcId to an Id by zonking its type + +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. + +The Ids are converted by binding them in the normal Tc envt; that +way we maintain sharing; eg an Id is zonked at its binding site and they +all occurrences of that Id point to the common zonked copy + +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. + +Note [Sharing when zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: + + In GHC.Tc.Zonk.TcType.zonkTcTyVar, we short-circuit (Indirect ty) to + (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Zonk.TcType. + But we /can't/ do this when zonking a TcType to a Type (#15552, esp comment:3). + Suppose we have + + alpha -> alpha + where + alpha is already unified: + alpha := T{tc-tycon} Int -> Int + and T is knot-tied + + By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, + but the global env contains a mapping "T" :-> T{knot-tied-tc}. See + Note [Type checking recursive type and class declarations] in + GHC.Tc.TyCl. + + Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow + the same path as Note [Sharing in zonking] in GHC.Tc.Zonk.TcType, we'll + update alpha to + alpha := T{knot-tied-tc} Int -> Int + + But alas, if we encounter alpha for a /second/ time, we end up + looking at T{knot-tied-tc} and fall into a black hole. The whole + point of zonkTcTypeToType is that it produces a type full of + knot-tied tycons, and you must not look at the result!! + + To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not + the same as zonkTcTypeToType. (If we distinguished TcType from + Type, this issue would have been a type error!) + +Solutions: (see #15552 for other variants) + +One possible solution is simply not to do the short-circuiting. +That has less sharing, but maybe sharing is rare. And indeed, +that usually turns out to be viable from a perf point of view + +But zonkTyVarOcc implements something a bit better + +* ZonkEnv contains ze_meta_tv_env, which maps + from a MetaTyVar (unification variable) + to a Type (not a TcType) + +* In zonkTyVarOcc, we check this map to see if we have zonked + this variable before. If so, use the previous answer; if not + zonk it, and extend the map. + +* The map is of course stateful, held in a TcRef. (That is unlike + the treatment of lexically-scoped variables in ze_tv_env and + ze_id_env.) + +* In zonkTyVarOcc we read the TcRef to look up the unification + variable: + - if we get a hit we use the zonked result; + - if not, in zonk_meta we see if the variable is `Indirect ty`, + zonk that, and update the map (in finish_meta) + But Nota Bene that the "update map" step must re-read the TcRef + (or, more precisely, use updTcRef) because the zonking of the + `Indirect ty` may have added lots of stuff to the map. See + #19668 for an example where this made an asymptotic difference! + +Is it worth the extra work of carrying ze_meta_tv_env? Some +non-systematic perf measurements suggest that compiler allocation is +reduced overall (by 0.5% or so) but compile time really doesn't +change. But in some cases it makes a HUGE difference: see test +T9198 and #19668. So yes, it seems worth it. + +Note [Using TcM for zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main zonking monads currently wrap TcM, because we need access to +the full TcM monad in order to expand typed TH splices. +See zonkExpr (HsTypedSplice s _) = ... + +After the Typed TH plan has been implemented, this should no longer be necessary, +and we should be able to use a stripped down monad, similar to the ZonkM monad +which we use for zonking within the typechecker (but we will need a place to +accumulate errors). + +Note [Inlining ZonkBndrT computations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Computations that use the ZonkBndrT monad transformer must be inlined: +ZonkBndrT uses continuation-passing style; failing to inline means applying +an unknown continuation (unknown function call), which prevents many +optimisations from taking place. + +See test cases T14683, which regresses without these changes. +-} + +-- Why do we use TcM below? See Note [Using TcM for zonking to Type] + +-- | Zonking monad for a computation that zonks to Type, reading from a 'ZonkEnv' +-- but not extending or modifying it. +-- +-- See Note [Zonking to Type]. +type ZonkTcM = ZonkT TcM + +-- | Zonking monad for a computation that zonks to Type, reading from +-- and extending or modifying a 'ZonkEnv'. +-- +-- See Note [Zonking to Type]. +type ZonkBndrTcM = ZonkBndrT TcM + +wrapLocZonkMA :: (a -> ZonkTcM b) -> GenLocated (SrcSpanAnn' ann) a + -> ZonkTcM (GenLocated (SrcSpanAnn' ann) b) +wrapLocZonkMA fn (L loc a) = ZonkT $ \ ze -> + setSrcSpanA loc $ + do { b <- runZonkT (fn a) ze + ; return (L loc b) } + +wrapLocZonkBndrMA :: (a -> ZonkBndrTcM b) -> GenLocated (SrcSpanAnn' ann) a + -> ZonkBndrTcM (GenLocated (SrcSpanAnn' ann) b) +wrapLocZonkBndrMA fn (L loc a) = ZonkBndrT $ \ k -> ZonkT $ \ ze -> + setSrcSpanA loc $ + runZonkT ( runZonkBndrT (fn a) $ \ b -> k (L loc b) ) ze + +-------------------------------------------------------------------------------- + +zonkTyBndrsX :: [TcTyVar] -> ZonkBndrTcM [TcTyVar] +zonkTyBndrsX = traverse zonkTyBndrX +{-# INLINE zonkTyBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced +-- +-- It does not clone: the new TyVar has the sane Name +-- as the old one. This important when zonking the +-- TyVarBndrs of a TyCon, whose Names may scope. +zonkTyBndrX tv + = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $ + do { ki <- noBinders $ zonkTcTypeToTypeX (tyVarKind tv) + -- Internal names tidy up better, for iface files. + ; let tv' = mkTyVar (tyVarName tv) ki + ; extendTyZonkEnv tv' + ; return tv' } +{-# INLINE zonkTyBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarBindersX :: [VarBndr TcTyVar vis] + -> ZonkBndrTcM [VarBndr TyVar vis] +zonkTyVarBindersX = traverse zonkTyVarBinderX +{-# INLINE zonkTyVarBindersX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarBinderX :: VarBndr TcTyVar vis + -> ZonkBndrTcM (VarBndr TyVar vis) +-- Takes a TcTyVar and guarantees to return a TyVar +zonkTyVarBinderX (Bndr tv vis) + = do { tv' <- zonkTyBndrX tv + ; return (Bndr tv' vis) } +{-# INLINE zonkTyVarBinderX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type +zonkTyVarOcc tv + = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv + + ; let lookup_in_tv_env -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv + -- This can happen for RuntimeUnk variables (which + -- should stay as RuntimeUnk), but I think it should + -- not happen for SkolemTv. + mkTyVarTy <$> updateTyVarKindM zonkTcTypeToTypeX tv + + Just tv' -> return (mkTyVarTy tv') + + zonk_meta ref Flexi + = do { kind <- zonkTcTypeToTypeX (tyVarKind tv) + ; ty <- commitFlexi tv kind + + ; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty -- Belt and braces + ; finish_meta ty } + + zonk_meta _ (Indirect ty) + = do { zty <- zonkTcTypeToTypeX ty + ; finish_meta zty } + + finish_meta ty + = do { extendMetaEnv tv ty + ; return ty } + + ; if isTcTyVar tv + then case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_tv_env + RuntimeUnk {} -> lookup_in_tv_env + MetaTv { mtv_ref = ref } + -> do { mb_ty <- lookupMetaTv tv + -- See Note [Sharing when zonking to Type] + ; case mb_ty of + Just ty -> return ty + Nothing -> do { mtv_details <- readTcRef ref + ; zonk_meta ref mtv_details } } + + -- This should never really happen; + -- TyVars should not occur in the typechecker + else lookup_in_tv_env } + +extendMetaEnv :: TcTyVar -> Type -> ZonkTcM () +extendMetaEnv tv ty = + ZonkT $ \ ( ZonkEnv { ze_meta_tv_env = mtv_env_ref } ) -> + updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) + +lookupMetaTv :: TcTyVar -> ZonkTcM (Maybe Type) +lookupMetaTv tv = + ZonkT $ \ ( ZonkEnv { ze_meta_tv_env = mtv_env_ref } ) -> + do { mtv_env <- readTcRef mtv_env_ref + ; return $ lookupVarEnv mtv_env tv } + +lookupTyVarX :: TcTyVar -> ZonkTcM TyVar +lookupTyVarX tv + = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv + ; let !res = case lookupVarEnv tv_env tv of + Just tv -> tv + Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) + ; return res } + +commitFlexi :: TcTyVar -> Kind -> ZonkTcM Type +commitFlexi tv zonked_kind + = do { flexi <- ze_flexi <$> getZonkEnv + ; lift $ case flexi of + SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) + + DefaultFlexi + -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar + -- But that sees only type variables that appear in, say, an inferred type. + -- Defaulting here, in the zonker, is needed to catch e.g. + -- y :: Bool + -- y = (\x -> True) undefined + -- We need *some* known RuntimeRep for the x and undefined, but no one + -- will choose it until we get here, in the zonker. + | isRuntimeRepTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) + ; return liftedRepTy } + | isLevityTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv) + ; return liftedDataConTy } + | isMultiplicityTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) + ; return manyDataConTy } + | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv + -> do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) + ; return (anyTypeOfKind zonked_kind) } + | otherwise + -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) + ; return (anyTypeOfKind zonked_kind) } + + RuntimeUnkFlexi + -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) + ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad + + NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) } + + where + name = tyVarName tv + + +zonkCoVarOcc :: CoVar -> ZonkTcM Coercion +zonkCoVarOcc cv + = do { ZonkEnv { ze_tv_env = tyco_env } <- getZonkEnv + -- don't look in the knot-tied env + ; case lookupVarEnv tyco_env cv of + Just cv' -> return $ mkCoVarCo cv' + _ -> mkCoVarCo <$> (lift $ liftZonkM $ zonkCoVar cv) } + +zonkCoHole :: CoercionHole -> ZonkTcM Coercion +zonkCoHole hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCoToCo co + ; lift $ liftZonkM $ checkCoercionHole cv co' } + + -- This next case should happen only in the presence of + -- (undeferred) type errors. Originally, I put in a panic + -- here, but that caused too many uses of `failIfErrsM`. + Nothing -> do { lift $ traceTc "Zonking unfilled coercion hole" (ppr hole) + ; cv' <- lift $ liftZonkM $ zonkCoVar cv + ; return $ mkCoVarCo cv' } } + -- This will be an out-of-scope variable, but keeping + -- this as a coercion hole led to #15787 + +zonk_tycomapper :: TyCoMapper ZonkEnv TcM +zonk_tycomapper = TyCoMapper + { tcm_tyvar = \ env tv -> runZonkT (zonkTyVarOcc tv) env + , tcm_covar = \ env cv -> runZonkT (zonkCoVarOcc cv) env + , tcm_hole = \ env co -> runZonkT (zonkCoHole co) env + , tcm_tycobinder = \ env tcv _vis k -> flip runZonkT env $ + runZonkBndrT (zonkTyBndrX tcv) $ + \ tcv' -> ZonkT $ \ env' -> (k env' tcv') + , tcm_tycon = \ tc -> zonkTcTyConToTyCon tc + } + +-- Zonk a TyCon by changing a TcTyCon to a regular TyCon +zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon +zonkTcTyConToTyCon tc + | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) + ; case thing of + ATyCon real_tc -> return real_tc + _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } + | otherwise = return tc -- it's already zonked + +-- | Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Zonk.Type". +zonkTcTypeToType :: TcType -> TcM Type +zonkTcTypeToType ty = initZonkEnv DefaultFlexi $ zonkTcTypeToTypeX ty + +zonkScaledTcTypeToTypeX :: Scaled TcType -> ZonkTcM (Scaled TcType) +zonkScaledTcTypeToTypeX (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX m + <*> zonkTcTypeToTypeX ty + +zonkTcTypeToTypeX :: TcType -> ZonkTcM Type +zonkTcTypesToTypesX :: [TcType] -> ZonkTcM [Type] +zonkCoToCo :: Coercion -> ZonkTcM Coercion +(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo) + = case mapTyCoX zonk_tycomapper of + (zty, ztys, zco, _) -> + (ZonkT . flip zty, ZonkT . flip ztys, ZonkT . flip zco) + +zonkScaledTcTypesToTypesX :: [Scaled TcType] -> ZonkTcM [Scaled Type] +zonkScaledTcTypesToTypesX scaled_tys = + mapM zonkScaledTcTypeToTypeX scaled_tys + + +zonkEnvIds :: ZonkEnv -> TypeEnv +zonkEnvIds (ZonkEnv { ze_id_env = id_env }) + = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- immediately by creating a TypeEnv + +zonkLIdOcc :: LocatedN TcId -> ZonkTcM (LocatedN Id) +zonkLIdOcc = traverse zonkIdOcc + +zonkIdOcc :: TcId -> ZonkTcM Id +-- Ids defined in this module should be in the envt; +-- ignore others. (Actually, data constructors are also +-- not LocalVars, even when locally defined, but that is fine.) +-- (Also foreign-imported things aren't currently in the ZonkEnv; +-- that's ok because they don't need zonking.) +-- +-- Actually, Template Haskell works in 'chunks' of declarations, and +-- an earlier chunk won't be in the 'env' that the zonking phase +-- carries around. Instead it'll be in the tcg_gbl_env, already fully +-- zonked. There's no point in looking it up there (except for error +-- checking), and it's not conveniently to hand; hence the simple +-- 'orElse' case in the LocalVar branch. +-- +-- Even without template splices, in module Main, the checking of +-- 'main' is done as a separate chunk. +zonkIdOcc id + | isLocalVar id = + do { ZonkEnv { ze_id_env = id_env } <- getZonkEnv + ; return $ lookupVarEnv id_env id `orElse` id } + | otherwise + = return id + +zonkIdOccs :: [TcId] -> ZonkTcM [Id] +zonkIdOccs ids = traverse zonkIdOcc ids + +-- zonkIdBndr is used *after* typechecking to get the Id's type +-- to its final form. The TyVarEnv give +zonkIdBndrX :: TcId -> ZonkBndrTcM Id +zonkIdBndrX v + = do { id <- noBinders $ zonkIdBndr v + ; extendIdZonkEnv id + ; return id } +{-# INLINE zonkIdBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkIdBndr :: TcId -> ZonkTcM Id +zonkIdBndr v + = do { Scaled w' ty' <- zonkScaledTcTypeToTypeX (idScaledType v) + ; return $ setIdMult (setIdType v ty') w' } + +zonkIdBndrs :: [TcId] -> ZonkTcM [Id] +zonkIdBndrs ids = mapM zonkIdBndr ids + +zonkTopBndrs :: [TcId] -> TcM [Id] +zonkTopBndrs ids = initZonkEnv DefaultFlexi $ zonkIdBndrs ids + +zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc) +zonkFieldOcc (FieldOcc sel lbl) + = fmap ((flip FieldOcc) lbl) $ zonkIdBndr sel + +zonkEvBndrsX :: [EvVar] -> ZonkBndrTcM [EvVar] +zonkEvBndrsX = traverse zonkEvBndrX +{-# INLINE zonkEvBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkEvBndrX :: EvVar -> ZonkBndrTcM EvVar +-- Works for dictionaries and coercions +zonkEvBndrX var + = do { var' <- noBinders $ zonkEvBndr var + ; extendZonkEnv [var'] + ; return var' } +{-# INLINE zonkEvBndr #-} -- See Note [Inlining ZonkBndrT computations] + +zonkEvBndr :: EvVar -> ZonkTcM EvVar +-- Works for dictionaries and coercions +-- Does not extend the ZonkEnv +zonkEvBndr var + = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX) var + +{- +zonkEvVarOcc :: EvVar -> ZonkTcM EvTerm +zonkEvVarOcc env v + | isCoVar v + = EvCoercion <$> zonkCoVarOcc env v + | otherwise + = return (EvId $ zonkIdOcc env v) +-} + +zonkCoreBndrX :: Var -> ZonkBndrTcM Var +zonkCoreBndrX v + | isId v = zonkIdBndrX v + | otherwise = zonkTyBndrX v +{-# INLINE zonkCoreBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkCoreBndrsX :: [Var] -> ZonkBndrTcM [Var] +zonkCoreBndrsX = traverse zonkCoreBndrX +{-# INLINE zonkCoreBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) +zonkTopExpr e = initZonkEnv DefaultFlexi $ zonkExpr e + +zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) +zonkTopLExpr e = initZonkEnv DefaultFlexi $ zonkLExpr e + +zonkTopDecls :: Bag EvBind + -> LHsBinds GhcTc + -> [LRuleDecl GhcTc] -> [LTcSpecPrag] + -> [LForeignDecl GhcTc] + -> TcM (TypeEnv, + Bag EvBind, + LHsBinds GhcTc, + [LForeignDecl GhcTc], + [LTcSpecPrag], + [LRuleDecl GhcTc]) +zonkTopDecls ev_binds binds rules imp_specs fords + = initZonkEnv DefaultFlexi $ + runZonkBndrT (zonkEvBinds ev_binds) $ \ ev_binds' -> + runZonkBndrT (zonkRecMonoBinds binds) $ \ binds' -> + -- Top level is implicitly recursive + do { rules' <- zonkRules rules + ; specs' <- zonkLTcSpecPrags imp_specs + ; fords' <- zonkForeignExports fords + ; ty_env <- zonkEnvIds <$> getZonkEnv + ; return (ty_env, ev_binds', binds', fords', specs', rules') } + + +--------------------------------------------- +zonkLocalBinds :: HsLocalBinds GhcTc + -> ZonkBndrTcM (HsLocalBinds GhcTc) +zonkLocalBinds (EmptyLocalBinds x) + = return (EmptyLocalBinds x) + +zonkLocalBinds (HsValBinds _ (ValBinds {})) + = panic "zonkLocalBinds" -- Not in typechecker output + +zonkLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) + = do { new_binds <- traverse go binds + ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } + where + go (r,b) + = do { b' <- zonkRecMonoBinds b + ; return (r,b') } + +zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do + new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds + extendIdZonkEnvRec [ n | (L _ (IPBind n _ _)) <- new_binds] + new_dict_binds <- zonkTcEvBinds dict_binds + return $ HsIPBinds x (IPBinds new_dict_binds new_binds) + where + zonk_ip_bind (IPBind dict_id n e) + = do dict_id' <- zonkIdBndr dict_id + e' <- zonkLExpr e + return (IPBind dict_id' n e') + +--------------------------------------------- +zonkRecMonoBinds :: LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc) +zonkRecMonoBinds binds + = mfix $ \ new_binds -> + do { extendIdZonkEnvRec (collectHsBindsBinders CollNoDictBinders new_binds) + ; noBinders $ zonkMonoBinds binds } + +--------------------------------------------- +zonkMonoBinds :: LHsBinds GhcTc -> ZonkTcM (LHsBinds GhcTc) +zonkMonoBinds binds = mapBagM zonk_lbind binds + +zonk_lbind :: LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc) +zonk_lbind = wrapLocZonkMA zonk_bind + +zonk_bind :: HsBind GhcTc -> ZonkTcM (HsBind GhcTc) +zonk_bind bind@(PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = (ty, ticks)}) + = do { new_pat <- don'tBind $ zonkPat pat -- Env already extended + ; new_grhss <- zonkGRHSs zonkLExpr grhss + ; new_ty <- zonkTcTypeToTypeX ty + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss + , pat_ext = (new_ty, ticks) }) } + +zonk_bind (VarBind { var_ext = x + , var_id = var, var_rhs = expr }) + = do { new_var <- zonkIdBndr var + ; new_expr <- zonkLExpr expr + ; return (VarBind { var_ext = x + , var_id = new_var + , var_rhs = new_expr }) } + +zonk_bind bind@(FunBind { fun_id = L loc var + , fun_matches = ms + , fun_ext = (co_fn, ticks) }) + = do { new_var <- zonkIdBndr var + ; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do { new_ms <- zonkMatchGroup zonkLExpr ms + ; return (bind { fun_id = L loc new_var + , fun_matches = new_ms + , fun_ext = (new_co_fn, ticks) }) } } + +zonk_bind (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs + , abs_ev_binds = ev_binds + , abs_exports = exports + , abs_binds = val_binds + , abs_sig = has_sig })) + = assert ( all isImmutableTyVar tyvars ) $ + runZonkBndrT (zonkTyBndrsX tyvars ) $ \ new_tyvars -> + runZonkBndrT (zonkEvBndrsX evs ) $ \ new_evs -> + runZonkBndrT (zonkTcEvBinds_s ev_binds) $ \ new_ev_binds -> + do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, _) -> + runZonkBndrT (extendIdZonkEnvRec $ collectHsBindsBinders CollNoDictBinders new_val_binds) $ \ _ -> + do { new_val_binds <- mapBagM zonk_val_bind val_binds + ; new_exports <- mapM zonk_export exports + ; return (new_val_binds, new_exports) + } + ; return $ XHsBindsLR $ + AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs + , abs_ev_binds = new_ev_binds + , abs_exports = new_exports, abs_binds = new_val_bind + , abs_sig = has_sig } } + where + zonk_val_bind lbind + | has_sig + , (L loc bind@(FunBind { fun_id = (L mloc mono_id) + , fun_matches = ms + , fun_ext = (co_fn, ticks) })) <- lbind + = do { new_mono_id <- updateIdTypeAndMultM zonkTcTypeToTypeX mono_id + -- Specifically /not/ zonkIdBndr; we do not want to + -- complain about a representation-polymorphic binder + ; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do { new_ms <- zonkMatchGroup zonkLExpr ms + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id + , fun_matches = new_ms + , fun_ext = (new_co_fn, ticks) } } } + | otherwise + = zonk_lbind lbind -- The normal case + + zonk_export :: ABExport -> ZonkTcM ABExport + zonk_export (ABE{ abe_wrap = wrap + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = prags }) + = do new_poly_id <- zonkIdBndr poly_id + new_wrap <- don'tBind $ zonkCoFn wrap + new_prags <- zonkSpecPrags prags + new_mono_id <- zonkIdOcc mono_id + return (ABE{ abe_wrap = new_wrap + , abe_poly = new_poly_id + , abe_mono = new_mono_id + , abe_prags = new_prags }) + +zonk_bind (PatSynBind x bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) + = do { id' <- zonkIdBndr id + ; runZonkBndrT (zonkPat lpat) $ \ lpat' -> + do { details' <- zonkPatSynDetails details + ; dir' <- zonkPatSynDir dir + ; return $ PatSynBind x $ + bind { psb_id = L loc id' + , psb_args = details' + , psb_def = lpat' + , psb_dir = dir' } } } + +zonkPatSynDetails :: HsPatSynDetails GhcTc + -> ZonkTcM (HsPatSynDetails GhcTc) +zonkPatSynDetails (PrefixCon _ as) + = PrefixCon noTypeArgs <$> traverse zonkLIdOcc as +zonkPatSynDetails (InfixCon a1 a2) + = InfixCon <$> zonkLIdOcc a1 <*> zonkLIdOcc a2 +zonkPatSynDetails (RecCon flds) + = RecCon <$> mapM zonkPatSynField flds + +zonkPatSynField :: RecordPatSynField GhcTc -> ZonkTcM (RecordPatSynField GhcTc) +zonkPatSynField (RecordPatSynField x y) = + RecordPatSynField <$> zonkFieldOcc x <*> zonkLIdOcc y + +zonkPatSynDir :: HsPatSynDir GhcTc + -> ZonkTcM (HsPatSynDir GhcTc) +zonkPatSynDir Unidirectional = return Unidirectional +zonkPatSynDir ImplicitBidirectional = return ImplicitBidirectional +zonkPatSynDir (ExplicitBidirectional mg) = ExplicitBidirectional <$> zonkMatchGroup zonkLExpr mg + +zonkSpecPrags :: TcSpecPrags -> ZonkTcM TcSpecPrags +zonkSpecPrags IsDefaultMethod = return IsDefaultMethod +zonkSpecPrags (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags ps + ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag] +zonkLTcSpecPrags ps + = mapM zonk_prag ps + where + zonk_prag (L loc (SpecPrag id co_fn inl)) + = do { co_fn' <- don'tBind $ zonkCoFn co_fn + ; id' <- zonkIdOcc id + ; return (L loc (SpecPrag id' co_fn' inl)) } + +{- +************************************************************************ +* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} +* * +************************************************************************ +-} + +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> MatchGroup GhcTc (LocatedA (body GhcTc)) + -> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc))) +zonkMatchGroup zBody (MG { mg_alts = L l ms + , mg_ext = MatchGroupTc arg_tys res_ty origin + }) + = do { ms' <- mapM (zonkMatch zBody) ms + ; arg_tys' <- zonkScaledTcTypesToTypesX arg_tys + ; res_ty' <- zonkTcTypeToTypeX res_ty + ; return (MG { mg_alts = L l ms' + , mg_ext = MatchGroupTc arg_tys' res_ty' origin + }) } + +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> LMatch GhcTc (LocatedA (body GhcTc)) + -> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc))) +zonkMatch zBody (L loc match@(Match { m_pats = pats + , m_grhss = grhss })) + = runZonkBndrT (zonkPats pats) $ \ new_pats -> + do { new_grhss <- zonkGRHSs zBody grhss + ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } + +------------------------------------------------------------------------- +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> GRHSs GhcTc (LocatedA (body GhcTc)) + -> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc))) + +zonkGRHSs zBody (GRHSs x grhss binds) = + runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do { new_grhss <- mapM (wrapLocZonkMA zonk_grhs) grhss + ; return (GRHSs x new_grhss new_binds) } + where + zonk_grhs (GRHS xx guarded rhs) = + runZonkBndrT (zonkStmts zonkLExpr guarded) $ \ new_guarded -> + GRHS xx new_guarded <$> zBody rhs + +{- +************************************************************************ +* * +\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} +* * +************************************************************************ +-} + +zonkLExprs :: [LHsExpr GhcTc] -> ZonkTcM [LHsExpr GhcTc] +zonkLExpr :: LHsExpr GhcTc -> ZonkTcM (LHsExpr GhcTc) +zonkExpr :: HsExpr GhcTc -> ZonkTcM (HsExpr GhcTc) + +zonkLExprs exprs = mapM zonkLExpr exprs +zonkLExpr expr = wrapLocZonkMA zonkExpr expr + +zonkExpr (HsVar x (L l id)) + = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $ + do { id' <- zonkIdOcc id + ; return (HsVar x (L l id')) } + +zonkExpr (HsUnboundVar her occ) + = do her' <- zonk_her her + return (HsUnboundVar her' occ) + where + zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef + zonk_her (HER ref ty u) + = do updTcRefM ref zonkEvTerm + ty' <- zonkTcTypeToTypeX ty + return (HER ref ty' u) + +zonkExpr (HsRecSel _ (FieldOcc v occ)) + = do { v' <- zonkIdOcc v + ; return (HsRecSel noExtField (FieldOcc v' occ)) } + +zonkExpr (HsIPVar x _) = dataConCantHappen x + +zonkExpr (HsOverLabel x _ _) = dataConCantHappen x + +zonkExpr (HsLit x (HsRat e f ty)) + = do new_ty <- zonkTcTypeToTypeX ty + return (HsLit x (HsRat e f new_ty)) + +zonkExpr (HsLit x lit) + = return (HsLit x lit) + +zonkExpr (HsOverLit x lit) + = do { lit' <- zonkOverLit lit + ; return (HsOverLit x lit') } + +zonkExpr (HsLam x matches) + = do new_matches <- zonkMatchGroup zonkLExpr matches + return (HsLam x new_matches) + +zonkExpr (HsLamCase x lc_variant matches) + = do new_matches <- zonkMatchGroup zonkLExpr matches + return (HsLamCase x lc_variant new_matches) + +zonkExpr (HsApp x e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (HsApp x new_e1 new_e2) + +zonkExpr (HsAppType ty e at t) + = do new_e <- zonkLExpr e + new_ty <- zonkTcTypeToTypeX ty + return (HsAppType new_ty new_e at t) + -- NB: the type is an HsType; can't zonk that! + +zonkExpr (HsTypedBracket hsb_tc body) + = (\x -> HsTypedBracket x body) <$> zonkBracket hsb_tc + +zonkExpr (HsUntypedBracket hsb_tc body) + = (\x -> HsUntypedBracket x body) <$> zonkBracket hsb_tc + +zonkExpr (HsTypedSplice s _) = ZonkT (\ _ -> runTopSplice s) >>= zonkExpr + +zonkExpr (HsUntypedSplice x _) = dataConCantHappen x + +zonkExpr (OpApp x _ _ _) = dataConCantHappen x + +zonkExpr (NegApp x expr op) + = runZonkBndrT (zonkSyntaxExpr op) $ \ new_op -> + do { new_expr <- zonkLExpr expr + ; return (NegApp x new_expr new_op) } + +zonkExpr (HsPar x lpar e rpar) + = do { new_e <- zonkLExpr e + ; return (HsPar x lpar new_e rpar) } + +zonkExpr (SectionL x _ _) = dataConCantHappen x +zonkExpr (SectionR x _ _) = dataConCantHappen x +zonkExpr (ExplicitTuple x tup_args boxed) + = do { new_tup_args <- mapM zonk_tup_arg tup_args + ; return (ExplicitTuple x new_tup_args boxed) } + where + zonk_tup_arg (Present x e) = do { e' <- zonkLExpr e + ; return (Present x e') } + zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX t + ; return (Missing t') } + + +zonkExpr (ExplicitSum args alt arity expr) + = do new_args <- mapM zonkTcTypeToTypeX args + new_expr <- zonkLExpr expr + return (ExplicitSum new_args alt arity new_expr) + +zonkExpr (HsCase x expr ms) + = do new_expr <- zonkLExpr expr + new_ms <- zonkMatchGroup zonkLExpr ms + return (HsCase x new_expr new_ms) + +zonkExpr (HsIf x e1 e2 e3) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_e3 <- zonkLExpr e3 + return (HsIf x new_e1 new_e2 new_e3) + +zonkExpr (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocZonkMA zonk_alt) alts + ; ty' <- zonkTcTypeToTypeX ty + ; return $ HsMultiIf ty' alts' } + where zonk_alt (GRHS x guard expr) + = runZonkBndrT (zonkStmts zonkLExpr guard) $ \ guard' -> + do { expr' <- zonkLExpr expr + ; return $ GRHS x guard' expr' } + +zonkExpr (HsLet x tkLet binds tkIn expr) + = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do { new_expr <- zonkLExpr expr + ; return (HsLet x tkLet new_binds tkIn new_expr) } + +zonkExpr (HsDo ty do_or_lc (L l stmts)) + = do new_stmts <- don'tBind $ zonkStmts zonkLExpr stmts + new_ty <- zonkTcTypeToTypeX ty + return (HsDo new_ty do_or_lc (L l new_stmts)) + +zonkExpr (ExplicitList ty exprs) + = do new_ty <- zonkTcTypeToTypeX ty + new_exprs <- zonkLExprs exprs + return (ExplicitList new_ty new_exprs) + +zonkExpr expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr con_expr + ; new_rbinds <- zonkRecFields rbinds + ; return (expr { rcon_ext = new_con_expr + , rcon_flds = new_rbinds }) } + +zonkExpr (ExprWithTySig _ e ty) + = do { e' <- zonkLExpr e + ; return (ExprWithTySig noExtField e' ty) } + +zonkExpr (ArithSeq expr wit info) + = do { new_expr <- zonkExpr expr + ; runZonkBndrT (zonkWit wit) $ \ new_wit -> + do { new_info <- zonkArithSeq info + ; return (ArithSeq new_expr new_wit new_info) } } + where zonkWit Nothing = return Nothing + zonkWit (Just fln) = Just <$> zonkSyntaxExpr fln + +zonkExpr (HsPragE x prag expr) + = do new_expr <- zonkLExpr expr + return (HsPragE x prag new_expr) + +-- arrow notation extensions +zonkExpr (HsProc x pat body) + = runZonkBndrT (zonkPat pat) $ \ new_pat -> + do { new_body <- zonkCmdTop body + ; return (HsProc x new_pat new_body) } + +-- StaticPointers extension +zonkExpr (HsStatic (fvs, ty) expr) + = do new_ty <- zonkTcTypeToTypeX ty + HsStatic (fvs, new_ty) <$> zonkLExpr expr + +zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr))) + = runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do new_expr <- zonkExpr expr + return (XExpr (WrapExpr (HsWrap new_co_fn new_expr))) + +zonkExpr (XExpr (ExpansionExpr (HsExpanded a b))) + = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr b + +zonkExpr (XExpr (ConLikeTc con tvs tys)) + = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys + where + zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX m <*> pure ty + -- Only the multiplicity can contain unification variables + -- The tvs come straight from the data-con, and so are strictly redundant + -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head + +zonkExpr (RecordUpd x _ _) = dataConCantHappen x +zonkExpr (HsGetField x _ _) = dataConCantHappen x +zonkExpr (HsProjection x _) = dataConCantHappen x +zonkExpr e@(XExpr (HsTick {})) = pprPanic "zonkExpr" (ppr e) +zonkExpr e@(XExpr (HsBinTick {})) = pprPanic "zonkExpr" (ppr e) + +------------------------------------------------------------------------- +{- +Note [Skolems in zonkSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider rebindable syntax with something like + + (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' + +The x and y become skolems that are in scope when type-checking the +arguments to the bind. This means that we must extend the ZonkEnv with +these skolems when zonking the arguments to the bind. But the skolems +are different between the two arguments, and so we should theoretically +carry around different environments to use for the different arguments. + +However, this becomes a logistical nightmare, especially in dealing with +the more exotic Stmt forms. So, we simplify by making the critical +assumption that the uniques of the skolems are different. (This assumption +is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.) +Now, we can safely just extend one environment. +-} + +-- See Note [Skolems in zonkSyntaxExpr] +zonkSyntaxExpr :: SyntaxExpr GhcTc + -> ZonkBndrTcM (SyntaxExpr GhcTc) +zonkSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = do { res_wrap' <- zonkCoFn res_wrap + ; expr' <- noBinders $ zonkExpr expr + ; arg_wraps' <- traverse zonkCoFn arg_wraps + ; return SyntaxExprTc { syn_expr = expr' + , syn_arg_wraps = arg_wraps' + , syn_res_wrap = res_wrap' } } +zonkSyntaxExpr NoSyntaxExprTc = return NoSyntaxExprTc + +------------------------------------------------------------------------- + +zonkLCmd :: LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc) +zonkCmd :: HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc) + +zonkLCmd cmd = wrapLocZonkMA zonkCmd cmd + +zonkCmd (XCmd (HsWrap w cmd)) + = runZonkBndrT (zonkCoFn w) $ \ w' -> + do { cmd' <- zonkCmd cmd + ; return (XCmd (HsWrap w' cmd')) } +zonkCmd (HsCmdArrApp ty e1 e2 ho rl) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_ty <- zonkTcTypeToTypeX ty + return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) + +zonkCmd (HsCmdArrForm x op f fixity args) + = do new_op <- zonkLExpr op + new_args <- mapM zonkCmdTop args + return (HsCmdArrForm x new_op f fixity new_args) + +zonkCmd (HsCmdApp x c e) + = do new_c <- zonkLCmd c + new_e <- zonkLExpr e + return (HsCmdApp x new_c new_e) + +zonkCmd (HsCmdLam x matches) + = do new_matches <- zonkMatchGroup zonkLCmd matches + return (HsCmdLam x new_matches) + +zonkCmd (HsCmdPar x lpar c rpar) + = do new_c <- zonkLCmd c + return (HsCmdPar x lpar new_c rpar) + +zonkCmd (HsCmdCase x expr ms) + = do new_expr <- zonkLExpr expr + new_ms <- zonkMatchGroup zonkLCmd ms + return (HsCmdCase x new_expr new_ms) + +zonkCmd (HsCmdLamCase x lc_variant ms) + = do new_ms <- zonkMatchGroup zonkLCmd ms + return (HsCmdLamCase x lc_variant new_ms) + +zonkCmd (HsCmdIf x eCond ePred cThen cElse) + = runZonkBndrT (zonkSyntaxExpr eCond) $ \ new_eCond -> + do { new_ePred <- zonkLExpr ePred + ; new_cThen <- zonkLCmd cThen + ; new_cElse <- zonkLCmd cElse + ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd (HsCmdLet x tkLet binds tkIn cmd) + = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do new_cmd <- zonkLCmd cmd + return (HsCmdLet x tkLet new_binds tkIn new_cmd) + +zonkCmd (HsCmdDo ty (L l stmts)) + = do new_stmts <- don'tBind $ zonkStmts zonkLCmd stmts + new_ty <- zonkTcTypeToTypeX ty + return (HsCmdDo new_ty (L l new_stmts)) + + + +zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc) +zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd + +zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc) +zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) + = do new_cmd <- zonkLCmd cmd + new_stack_tys <- zonkTcTypeToTypeX stack_tys + new_ty <- zonkTcTypeToTypeX ty + new_ids <- mapSndM zonkExpr ids + + massert (isLiftedTypeKind (typeKind new_stack_tys)) + -- desugarer assumes that this is not representation-polymorphic... + -- but indeed it should always be lifted due to the typing + -- rules for arrows + + return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) + +------------------------------------------------------------------------- +zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper +zonkCoFn WpHole = return WpHole +zonkCoFn (WpCompose c1 c2) = do { c1' <- zonkCoFn c1 + ; c2' <- zonkCoFn c2 + ; return (WpCompose c1' c2') } +zonkCoFn (WpFun c1 c2 t1) = do { c1' <- zonkCoFn c1 + ; c2' <- zonkCoFn c2 + ; t1' <- noBinders $ zonkScaledTcTypeToTypeX t1 + ; return (WpFun c1' c2' t1') } +zonkCoFn (WpCast co) = WpCast <$> noBinders (zonkCoToCo co) +zonkCoFn (WpEvLam ev) = WpEvLam <$> zonkEvBndrX ev +zonkCoFn (WpEvApp arg) = WpEvApp <$> noBinders (zonkEvTerm arg) +zonkCoFn (WpTyLam tv) = assert (isImmutableTyVar tv) $ + WpTyLam <$> zonkTyBndrX tv +zonkCoFn (WpTyApp ty) = WpTyApp <$> noBinders (zonkTcTypeToTypeX ty) +zonkCoFn (WpLet bs) = WpLet <$> zonkTcEvBinds bs +zonkCoFn (WpMultCoercion co) = WpMultCoercion <$> noBinders (zonkCoToCo co) + +------------------------------------------------------------------------- +zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc) +zonkOverLit lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } }) + = do { ty' <- zonkTcTypeToTypeX ty + ; e' <- zonkExpr e + ; return (lit { ol_ext = x { ol_witness = e' + , ol_type = ty' } }) } + +------------------------------------------------------------------------- +zonkBracket :: HsBracketTc -> ZonkTcM HsBracketTc +zonkBracket (HsBracketTc hsb_thing ty wrap bs) + = do wrap' <- traverse zonkQuoteWrap wrap + bs' <- mapM zonk_b bs + new_ty <- zonkTcTypeToTypeX ty + return (HsBracketTc hsb_thing new_ty wrap' bs') + where + zonkQuoteWrap (QuoteWrapper ev ty) = do + ev' <- zonkIdOcc ev + ty' <- zonkTcTypeToTypeX ty + return (QuoteWrapper ev' ty') + + zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr e + return (PendingTcSplice n e') + +------------------------------------------------------------------------- +zonkArithSeq :: ArithSeqInfo GhcTc -> ZonkTcM (ArithSeqInfo GhcTc) + +zonkArithSeq (From e) + = do new_e <- zonkLExpr e + return (From new_e) + +zonkArithSeq (FromThen e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (FromThen new_e1 new_e2) + +zonkArithSeq (FromTo e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (FromTo new_e1 new_e2) + +zonkArithSeq (FromThenTo e1 e2 e3) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_e3 <- zonkLExpr e3 + return (FromThenTo new_e1 new_e2 new_e3) + +------------------------------------------------------------------------- +zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> [LStmt GhcTc (LocatedA (body GhcTc))] + -> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))] +zonkStmts _ [] = return [] +zonkStmts zBody (s:ss) = do { s' <- wrapLocZonkBndrMA (zonkStmt zBody) s + ; ss' <- zonkStmts zBody ss + ; return (s' : ss') } + +zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> Stmt GhcTc (LocatedA (body GhcTc)) + -> ZonkBndrTcM (Stmt GhcTc (LocatedA (body GhcTc))) +zonkStmt _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) + = do { new_bind_op <- zonkSyntaxExpr bind_op + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty + ; new_stmts_w_bndrs <- noBinders $ mapM zonk_branch stmts_w_bndrs + + -- Add in the binders after we're done with all the branches. + ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs + , b <- bs ] + ; extendIdZonkEnvRec new_binders + ; new_mzip <- noBinders $ zonkExpr mzip_op + ; return (ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} + where + zonk_branch :: ParStmtBlock GhcTc GhcTc + -> ZonkTcM (ParStmtBlock GhcTc GhcTc) + zonk_branch (ParStmtBlock x stmts bndrs return_op) + = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts -> + runZonkBndrT (zonkSyntaxExpr return_op) $ \ new_return -> + do { new_bndrs <- zonkIdOccs bndrs + ; return (ParStmtBlock x new_stmts new_bndrs new_return) } + +zonkStmt zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs + , recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id + , recS_bind_fn = bind_id + , recS_ext = + RecStmtTc { recS_bind_ty = bind_ty + , recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty} }) + = do { new_bind_id <- zonkSyntaxExpr bind_id + ; new_mfix_id <- zonkSyntaxExpr mfix_id + ; new_ret_id <- zonkSyntaxExpr ret_id + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty + ; new_rvs <- noBinders $ zonkIdBndrs rvs + ; new_lvs <- noBinders $ zonkIdBndrs lvs + ; new_ret_ty <- noBinders $ zonkTcTypeToTypeX ret_ty + + -- Zonk the ret-expressions in an environment that + -- has the polymorphic bindings + ; rec_stmt <- noBinders $ don'tBind $ + do { extendIdZonkEnvRec new_rvs + ; new_segStmts <- zonkStmts zBody segStmts + ; new_later_rets <- noBinders $ mapM zonkExpr later_rets + ; new_rec_rets <- noBinders $ mapM zonkExpr rec_rets + ; return $ + RecStmt { recS_stmts = noLocA new_segStmts + , recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_ext = RecStmtTc + { recS_bind_ty = new_bind_ty + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets + , recS_ret_ty = new_ret_ty } } } + + -- Only the lvs are needed + ; extendIdZonkEnvRec new_lvs + ; return rec_stmt } + +zonkStmt zBody (BodyStmt ty body then_op guard_op) + = do { new_then_op <- zonkSyntaxExpr then_op + ; new_guard_op <- zonkSyntaxExpr guard_op + ; new_body <- noBinders $ zBody body + ; new_ty <- noBinders $ zonkTcTypeToTypeX ty + ; return $ BodyStmt new_ty new_body new_then_op new_guard_op } + +zonkStmt zBody (LastStmt x body noret ret_op) + = noBinders $ runZonkBndrT (zonkSyntaxExpr ret_op) $ \ new_ret -> + do { new_body <- zBody body + ; return $ LastStmt x new_body noret new_ret } + +zonkStmt _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = bind_arg_ty + , trS_fmap = liftM_op }) + = do { bind_op' <- zonkSyntaxExpr bind_op + ; bind_arg_ty' <- noBinders $ zonkTcTypeToTypeX bind_arg_ty + ; stmts' <- zonkStmts zonkLExpr stmts + ; by' <- noBinders $ traverse zonkLExpr by + ; using' <- noBinders $ zonkLExpr using + ; return_op' <- zonkSyntaxExpr return_op + ; liftM_op' <- noBinders $ zonkExpr liftM_op + ; binderMap' <- mapM zonkBinderMapEntry binderMap + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = bind_arg_ty' + , trS_fmap = liftM_op' }) } + where + zonkBinderMapEntry (oldBinder, newBinder) = do + oldBinder' <- noBinders $ zonkIdOcc oldBinder + newBinder' <- zonkIdBndrX newBinder + return (oldBinder', newBinder') + +zonkStmt _ (LetStmt x binds) + = LetStmt x <$> zonkLocalBinds binds + +zonkStmt zBody (BindStmt xbs pat body) + = do { new_bind <- zonkSyntaxExpr (xbstc_bindOp xbs) + ; new_w <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultMult xbs) + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultType xbs) + ; new_body <- noBinders $ zBody body + ; new_fail <- case xbstc_failOp xbs of + Nothing -> return Nothing + Just fail_op -> fmap Just <$> noBinders $ don'tBind (zonkSyntaxExpr fail_op) + + ; new_pat <- zonkPat pat + ; return $ + BindStmt + (XBindStmtTc + { xbstc_bindOp = new_bind + , xbstc_boundResultType = new_bind_ty + , xbstc_boundResultMult = new_w + , xbstc_failOp = new_fail + }) + new_pat new_body } + +-- Scopes: join > ops (in reverse order) > pats (in forward order) +-- > rest of stmts +zonkStmt _zBody (ApplicativeStmt body_ty args mb_join) + = do { new_mb_join <- zonk_join mb_join + ; new_args <- zonk_args args + ; new_body_ty <- noBinders $ zonkTcTypeToTypeX body_ty + ; return $ ApplicativeStmt new_body_ty new_args new_mb_join } + where + zonk_join Nothing = return Nothing + zonk_join (Just j) = Just <$> zonkSyntaxExpr j + + get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc + get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat + + replace_pat :: LPat GhcTc + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) + = (op, ApplicativeArgOne fail_op pat a isBody) + replace_pat pat (op, ApplicativeArgMany x a b _ c) + = (op, ApplicativeArgMany x a b pat c) + + zonk_args args + = do { new_args_rev <- zonk_args_rev (reverse args) + ; new_pats <- zonkPats (map get_pat args) + ; return $ zipWithEqual "zonkStmt" replace_pat + new_pats (reverse new_args_rev) } + + -- these need to go backward, because if any operators are higher-rank, + -- later operators may introduce skolems that are in scope for earlier + -- arguments + zonk_args_rev ((op, arg) : args) + = do { new_op <- zonkSyntaxExpr op + ; new_arg <- noBinders $ zonk_arg arg + ; new_args <- zonk_args_rev args + ; return $ (new_op, new_arg) : new_args } + zonk_args_rev [] = return [] + + zonk_arg (ApplicativeArgOne fail_op pat expr isBody) + = do { new_expr <- zonkLExpr expr + ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr + ; return (ApplicativeArgOne new_fail pat new_expr isBody) } + zonk_arg (ApplicativeArgMany x stmts ret pat ctxt) + = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts -> + do { new_ret <- zonkExpr ret + ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } + +------------------------------------------------------------------------- +zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc) +zonkRecFields (HsRecFields flds dd) + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields flds' dd) } + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocZonkMA zonkFieldOcc (hfbLHS fld) + ; new_expr <- zonkLExpr (hfbRHS fld) + ; return (L l (fld { hfbLHS = new_id + , hfbRHS = new_expr })) } + +{- +************************************************************************ +* * +\subsection[BackSubst-Pats]{Patterns} +* * +************************************************************************ +-} + +zonkPat :: LPat GhcTc -> ZonkBndrTcM (LPat GhcTc) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat pat = wrapLocZonkBndrMA zonk_pat pat + +zonk_pat :: Pat GhcTc -> ZonkBndrTcM (Pat GhcTc) +zonk_pat (ParPat x lpar p rpar) + = do { p' <- zonkPat p + ; return (ParPat x lpar p' rpar) } + +zonk_pat (WildPat ty) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (WildPat ty') } + +zonk_pat (VarPat x (L l v)) + = do { v' <- zonkIdBndrX v + ; return (VarPat x (L l v')) } + +zonk_pat (LazyPat x pat) + = do { pat' <- zonkPat pat + ; return (LazyPat x pat') } + +zonk_pat (BangPat x pat) + = do { pat' <- zonkPat pat + ; return (BangPat x pat') } + +zonk_pat (AsPat x (L loc v) at pat) + = do { v' <- zonkIdBndrX v + ; pat' <- zonkPat pat + ; return (AsPat x (L loc v') at pat') } + +zonk_pat (ViewPat ty expr pat) + = do { expr' <- noBinders $ zonkLExpr expr + ; pat' <- zonkPat pat + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (ViewPat ty' expr' pat') } + +zonk_pat (ListPat ty pats) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pats' <- zonkPats pats + ; return (ListPat ty' pats') } + +zonk_pat (TuplePat tys pats boxed) + = do { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys + ; pats' <- zonkPats pats + ; return (TuplePat tys' pats' boxed) } + +zonk_pat (SumPat tys pat alt arity ) + = do { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys + ; pat' <- zonkPat pat + ; return (SumPat tys' pat' alt arity) } + +zonk_pat p@(ConPat { pat_args = args + , pat_con_ext = p'@(ConPatTc + { cpt_tvs = tyvars + , cpt_dicts = evs + , cpt_binds = binds + , cpt_wrap = wrapper + , cpt_arg_tys = tys + }) + }) + = assert (all isImmutableTyVar tyvars) $ + do { new_tys <- noBinders $ mapM zonkTcTypeToTypeX tys + ; new_tyvars <- zonkTyBndrsX tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; new_evs <- zonkEvBndrsX evs + ; new_binds <- zonkTcEvBinds binds + ; new_wrapper <- zonkCoFn wrapper + ; new_args <- zonkConStuff args + ; pure $ p + { pat_args = new_args + , pat_con_ext = p' + { cpt_arg_tys = new_tys + , cpt_tvs = new_tyvars + , cpt_dicts = new_evs + , cpt_binds = new_binds + , cpt_wrap = new_wrapper + } + } + } + +zonk_pat (LitPat x lit) = return (LitPat x lit) + +zonk_pat (SigPat ty pat hs_ty) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pat' <- zonkPat pat + ; return (SigPat ty' pat' hs_ty) } + +zonk_pat (NPat ty (L l lit) mb_neg eq_expr) + = do { eq_expr' <- zonkSyntaxExpr eq_expr + ; mb_neg' <- case mb_neg of + Nothing -> return Nothing + Just n -> Just <$> zonkSyntaxExpr n + ; noBinders $ + do { lit' <- zonkOverLit lit + ; ty' <- zonkTcTypeToTypeX ty + ; return (NPat ty' (L l lit') mb_neg' eq_expr') } } + +zonk_pat (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) + = do { e1' <- zonkSyntaxExpr e1 + ; e2' <- zonkSyntaxExpr e2 + ; lit1' <- noBinders $ zonkOverLit lit1 + ; lit2' <- noBinders $ zonkOverLit lit2 + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; n' <- zonkIdBndrX n + ; return (NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } + +zonk_pat (XPat ext) = case ext of + { ExpansionPat orig pat-> + do { pat' <- zonk_pat pat + ; return $ XPat $ ExpansionPat orig pat' } + ; CoPat co_fn pat ty -> + do { co_fn' <- zonkCoFn co_fn + ; pat' <- zonkPat (noLocA pat) + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (XPat $ CoPat co_fn' (unLoc pat') ty') + } } + +zonk_pat pat = pprPanic "zonk_pat" (ppr pat) + +--------------------------- +zonkConStuff :: HsConPatDetails GhcTc + -> ZonkBndrTcM (HsConPatDetails GhcTc) +zonkConStuff (PrefixCon tyargs pats) + = do { pats' <- zonkPats pats + ; return (PrefixCon tyargs pats') } + +zonkConStuff (InfixCon p1 p2) + = do { p1' <- zonkPat p1 + ; p2' <- zonkPat p2 + ; return (InfixCon p1' p2') } + +zonkConStuff (RecCon (HsRecFields rpats dd)) + = do { pats' <- zonkPats (map (hfbRHS . unLoc) rpats) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hfbRHS = p' })) + rpats pats' + ; return (RecCon (HsRecFields rpats' dd)) } + -- Field selectors have declared types; hence no zonking + +--------------------------- +zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] +zonkPats = traverse zonkPat + +{- +************************************************************************ +* * +\subsection[BackSubst-Foreign]{Foreign exports} +* * +************************************************************************ +-} + +zonkForeignExports :: [LForeignDecl GhcTc] + -> ZonkTcM [LForeignDecl GhcTc] +zonkForeignExports ls = mapM (wrapLocZonkMA zonkForeignExport) ls + +zonkForeignExport :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc) +zonkForeignExport (ForeignExport { fd_name = i, fd_e_ext = co + , fd_fe = spec }) + = do { i' <- zonkLIdOcc i + ; return (ForeignExport { fd_name = i' + , fd_sig_ty = undefined, fd_e_ext = co + , fd_fe = spec }) } +zonkForeignExport for_imp + = return for_imp -- Foreign imports don't need zonking + +zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc] +zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs + +zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc) +zonkRule rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} + , rd_lhs = lhs + , rd_rhs = rhs }) + = runZonkBndrT (traverse zonk_tm_bndr tm_bndrs) $ \ new_tm_bndrs -> + do { -- See Note [Zonking the LHS of a RULE] + ; new_lhs <- setZonkType SkolemiseFlexi $ zonkLExpr lhs + ; new_rhs <- zonkLExpr rhs + ; return $ rule { rd_tmvs = new_tm_bndrs + , rd_lhs = new_lhs + , rd_rhs = new_rhs } } + where + zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc) + zonk_tm_bndr (L l (RuleBndr x (L loc v))) + = do { v' <- zonk_it v + ; return (L l (RuleBndr x (L loc v'))) } + zonk_tm_bndr (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + + zonk_it v + | isId v = zonkIdBndrX v + | otherwise = assert (isImmutableTyVar v) + zonkTyBndrX v + -- DV: used to be "return v", but that is plain + -- wrong because we may need to go inside the kind + -- of v and zonk there! + +{- +************************************************************************ +* * + Constraints and evidence +* * +************************************************************************ +-} + +zonkEvTerm :: EvTerm -> ZonkTcM EvTerm +zonkEvTerm (EvExpr e) + = EvExpr <$> zonkCoreExpr e +zonkEvTerm (EvTypeable ty ev) + = EvTypeable <$> zonkTcTypeToTypeX ty <*> zonkEvTypeable ev +zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs + , et_binds = ev_binds, et_body = body_id }) + = runZonkBndrT (zonkTyBndrsX tvs) $ \ new_tvs -> + runZonkBndrT (zonkEvBndrsX evs) $ \ new_evs -> + runZonkBndrT (zonkTcEvBinds ev_binds) $ \ new_ev_binds -> + do { new_body_id <- zonkIdOcc body_id + ; return (EvFun { et_tvs = new_tvs, et_given = new_evs + , et_binds = new_ev_binds, et_body = new_body_id }) } + +zonkCoreExpr :: CoreExpr -> ZonkTcM CoreExpr +zonkCoreExpr (Var v) + | isCoVar v + = Coercion <$> zonkCoVarOcc v + | otherwise + = Var <$> zonkIdOcc v +zonkCoreExpr (Lit l) + = return $ Lit l +zonkCoreExpr (Coercion co) + = Coercion <$> zonkCoToCo co +zonkCoreExpr (Type ty) + = Type <$> zonkTcTypeToTypeX ty + +zonkCoreExpr (Cast e co) + = Cast <$> zonkCoreExpr e <*> zonkCoToCo co +zonkCoreExpr (Tick t e) + = Tick t <$> zonkCoreExpr e -- Do we need to zonk in ticks? + +zonkCoreExpr (App e1 e2) + = App <$> zonkCoreExpr e1 <*> zonkCoreExpr e2 +zonkCoreExpr (Lam v e) + = runZonkBndrT (zonkCoreBndrX v) $ \ v' -> + Lam v' <$> zonkCoreExpr e +zonkCoreExpr (Let bind e) + = runZonkBndrT (zonkCoreBind bind) $ \ bind' -> + Let bind' <$> zonkCoreExpr e +zonkCoreExpr (Case scrut b ty alts) + = do { scrut' <- zonkCoreExpr scrut + ; ty' <- zonkTcTypeToTypeX ty + ; runZonkBndrT (zonkIdBndrX b) $ \ b' -> + do { alts' <- mapM zonkCoreAlt alts + ; return $ Case scrut' b' ty' alts' } } + +zonkCoreAlt :: CoreAlt -> ZonkTcM CoreAlt +zonkCoreAlt (Alt dc bndrs rhs) + = runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' -> + do { rhs' <- zonkCoreExpr rhs + ; return $ Alt dc bndrs' rhs' } + +zonkCoreBind :: CoreBind -> ZonkBndrTcM CoreBind +zonkCoreBind (NonRec v e) + = do { (v',e') <- noBinders $ zonkCorePair (v,e) + ; extendIdZonkEnv v' + ; return (NonRec v' e') } +zonkCoreBind (Rec pairs) + = do pairs' <- mfix go + return $ Rec pairs' + where + go new_pairs = do + extendIdZonkEnvRec (map fst new_pairs) + noBinders $ mapM zonkCorePair pairs + +zonkCorePair :: (CoreBndr, CoreExpr) -> ZonkTcM (CoreBndr, CoreExpr) +zonkCorePair (v,e) = + do { v' <- zonkIdBndr v + ; e' <- zonkCoreExpr e + ; return (v',e') } + +zonkEvTypeable :: EvTypeable -> ZonkTcM EvTypeable +zonkEvTypeable (EvTypeableTyCon tycon e) + = do { e' <- mapM zonkEvTerm e + ; return $ EvTypeableTyCon tycon e' } +zonkEvTypeable (EvTypeableTyApp t1 t2) + = do { t1' <- zonkEvTerm t1 + ; t2' <- zonkEvTerm t2 + ; return (EvTypeableTyApp t1' t2') } +zonkEvTypeable (EvTypeableTrFun tm t1 t2) + = do { tm' <- zonkEvTerm tm + ; t1' <- zonkEvTerm t1 + ; t2' <- zonkEvTerm t2 + ; return (EvTypeableTrFun tm' t1' t2') } +zonkEvTypeable (EvTypeableTyLit t1) + = do { t1' <- zonkEvTerm t1 + ; return (EvTypeableTyLit t1') } + +zonkTcEvBinds_s :: [TcEvBinds] -> ZonkBndrTcM [TcEvBinds] +zonkTcEvBinds_s bs = do { bs' <- traverse zonk_tc_ev_binds bs + ; return ([EvBinds (unionManyBags bs')]) } + +zonkTcEvBinds :: TcEvBinds -> ZonkBndrTcM TcEvBinds +zonkTcEvBinds bs = do { bs' <- zonk_tc_ev_binds bs + ; return (EvBinds bs') } + +zonk_tc_ev_binds :: TcEvBinds -> ZonkBndrTcM (Bag EvBind) +zonk_tc_ev_binds (TcEvBinds var) = zonkEvBindsVar var +zonk_tc_ev_binds (EvBinds bs) = zonkEvBinds bs + +zonkEvBindsVar :: EvBindsVar -> ZonkBndrTcM (Bag EvBind) +zonkEvBindsVar (EvBindsVar { ebv_binds = ref }) + = do { bs <- readTcRef ref + ; zonkEvBinds (evBindMapBinds bs) } +zonkEvBindsVar (CoEvBindsVar {}) = return emptyBag + +zonkEvBinds :: Bag EvBind -> ZonkBndrTcM (Bag EvBind) +zonkEvBinds binds + = {-# SCC "zonkEvBinds" #-} + mfix $ \ new_binds -> + do { extendIdZonkEnvRec (collect_ev_bndrs new_binds) + ; noBinders $ mapBagM zonkEvBind binds } + where + collect_ev_bndrs :: Bag EvBind -> [EvVar] + collect_ev_bndrs = foldr add [] + add (EvBind { eb_lhs = var }) vars = var : vars + +zonkEvBind :: EvBind -> ZonkTcM EvBind +zonkEvBind bind@(EvBind { eb_lhs = var, eb_rhs = term }) + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr var + + -- Optimise the common case of Refl coercions + -- See Note [Optimise coercion zonking] + -- This has a very big effect on some programs (eg #5030) + + ; term' <- case getEqPredTys_maybe (idType var') of + Just (r, ty1, ty2) | ty1 `eqType` ty2 + -> return (evCoercion (mkReflCo r ty1)) + _other -> zonkEvTerm term + + ; return (bind { eb_lhs = var', eb_rhs = term' }) } + +{- Note [Optimise coercion zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When optimising evidence binds we may come across situations where +a coercion looks like + cv = ReflCo ty +or cv1 = cv2 +where the type 'ty' is big. In such cases it is a waste of time to zonk both + * The variable on the LHS + * The coercion on the RHS +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. + +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) +-} + +zonkTcMethInfoToMethInfoX :: TcMethInfo -> ZonkTcM MethInfo +zonkTcMethInfoToMethInfoX (name, ty, gdm_spec) + = do { ty' <- zonkTcTypeToTypeX ty + ; gdm_spec' <- zonk_gdm gdm_spec + ; return (name, ty', gdm_spec') } + where + zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) + -> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Type))) + zonk_gdm Nothing = return Nothing + zonk_gdm (Just VanillaDM) = return (Just VanillaDM) + zonk_gdm (Just (GenericDM (loc, ty))) + = do { ty' <- zonkTcTypeToTypeX ty + ; return (Just (GenericDM (loc, ty'))) } + +--------------------------------------- +{- Note [Zonking the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] + +We need to gather the type variables mentioned on the LHS so we can +quantify over them. Example: + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)) and we do +not want to zap the unbound meta-tyvar 'alpha' to Any, because that +limits the applicability of the rule. Instead, we want to quantify +over it! + +We do this in two stages. + +* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We + do this by using zonkTvSkolemising as the UnboundTyVarZonker in the + ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a + UnboundTyVarZonker.) + +* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds + Note [Free tyvars on rule LHS] + +Quantifying here is awkward because (a) the data type is big and (b) +finding the free type vars of an expression is necessarily monadic +operation. (consider /\a -> f @ b, where b is side-effected to a) +-} + +{- +************************************************************************ +* * + Checking for coercion holes +* * +************************************************************************ +-} + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> TcM Bool +isFilledCoercionHole (CoercionHole { ch_ref = ref }) + = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> TcM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref + +zonkCtRewriterSet :: Ct -> TcM Ct +zonkCtRewriterSet ct + | isGivenCt ct + = return ct + | otherwise + = case ct of + CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CEqCan (eq { eq_ev = ev' })) } + CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CDictCan (di { di_ev = ev' })) } + CQuantCan {} -> return ct + CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CNonCanonical ev') } + +zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence +zonkCtEvRewriterSet ev@(CtGiven {}) + = return ev +zonkCtEvRewriterSet ev@(CtWanted { ctev_rewriters = rewriters }) + = do { rewriters' <- zonkRewriterSet rewriters + ; return (ev { ctev_rewriters = rewriters' }) } + +-- | Check whether any coercion hole in a RewriterSet is still unsolved. +-- Does this by recursively looking through filled coercion holes until +-- one is found that is not yet filled in, at which point this aborts. +zonkRewriterSet :: RewriterSet -> TcM RewriterSet +zonkRewriterSet (RewriterSet set) + = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set + -- this does not introduce non-determinism, because the only + -- monadic action is to read, and the combining function is + -- commutative + where + go :: CoercionHole -> TcM RewriterSet -> TcM RewriterSet + go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc + + check_hole :: CoercionHole -> TcM RewriterSet + check_hole hole = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return (unitRewriterSet hole) + Just co -> unUCHM (check_co co) } + + check_ty :: Type -> UnfilledCoercionHoleMonoid + check_co :: Coercion -> UnfilledCoercionHoleMonoid + (check_ty, _, check_co, _) = foldTyCo folder () + + folder :: TyCoFolder () UnfilledCoercionHoleMonoid + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) + , tcf_covar = \ _ cv -> check_ty (varType cv) + , tcf_hole = \ _ -> UCHM . check_hole + , tcf_tycobinder = \ _ _ _ -> () } + +newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM RewriterSet } + +instance Semigroup UnfilledCoercionHoleMonoid where + UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) + +instance Monoid UnfilledCoercionHoleMonoid where + mempty = UCHM (return emptyRewriterSet) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -27,10 +28,9 @@ ) where -import GHC.Prelude hiding (head, init, last, tail) +import GHC.Prelude hiding (init, last, tail) import GHC.Hs as Hs -import GHC.Builtin.Names import GHC.Tc.Errors.Types import GHC.Types.Name.Reader import qualified GHC.Types.Name as Name @@ -63,13 +63,13 @@ import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe( catMaybes, isNothing ) -import Data.Word (Word64) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH import Foreign.ForeignPtr import Foreign.Ptr import System.IO.Unsafe + ------------------------------------------------------------------- -- The external interface @@ -276,13 +276,13 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr cNameN constr + ; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = NewTypeCon con' + , dd_cons = con' , dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ DataDecl { tcdDExt = noAnn @@ -327,10 +327,10 @@ where overlap pragma = case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT") + TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "OVERLAPS") + TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "OVERLAPPABLE") + TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "OVERLAPPING") + TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "INCOHERENT") @@ -348,13 +348,13 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM (cvtConstr cNameN) constrs + ; cons' <- cvtDataDefnCons False ksig $ DataTypeCons False constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = DataTypeCons False cons' + , dd_cons = cons' , dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD @@ -370,13 +370,14 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr cNameN constr + ; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = NewTypeCon con', dd_derivs = derivs' } + , dd_cons = con' + , dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = @@ -441,7 +442,8 @@ cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2 cvtArgs (TH.RecordPatSyn sels) - = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels + = do { let mk_fld = fldNameN (nameBase nm) + ; sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . mk_fld) sels ; vars' <- mapM (vNameN . mkNameS . nameBase) sels ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } @@ -465,7 +467,7 @@ = failWith InvalidImplicitParamBinding -- Convert a @data@ declaration. -cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] +cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] -> CvtM (Maybe (LHsDecl GhcPs)) cvtDataDec = cvtGenDataDec False @@ -473,17 +475,39 @@ -- Convert a @type data@ declaration. -- These have neither contexts nor derived clauses. -- See Note [Type data declarations] in GHC.Rename.Module. -cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr ()] -> Maybe TH.Kind -> [TH.Con] +cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] -> CvtM (Maybe (LHsDecl GhcPs)) cvtTypeDataDec tc tvs ksig constrs = cvtGenDataDec True [] tc tvs ksig constrs [] -- Convert a @data@ or @type data@ declaration (flagged by the Bool arg). -- See Note [Type data declarations] in GHC.Rename.Module. -cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] +cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] -> CvtM (Maybe (LHsDecl GhcPs)) cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- cvtDataDefnCons type_data ksig $ + DataTypeCons type_data constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noExtField + , dd_cType = Nothing + , dd_ctxt = mkHsContextMaybe ctxt' + , dd_kindSig = ksig' + , dd_cons = cons' + , dd_derivs = derivs' } + ; returnJustLA $ TyClD noExtField $ + DataDecl { tcdDExt = noAnn + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + +-- Convert a set of data constructors. +cvtDataDefnCons :: + Bool -> Maybe TH.Kind -> + DataDefnCons TH.Con -> CvtM (DataDefnCons (LConDecl GhcPs)) +cvtDataDefnCons type_data ksig constrs = do { let isGadtCon (GadtC _ _ _) = True isGadtCon (RecGadtC _ _ _) = True isGadtCon (ForallC _ _ c) = isGadtCon c @@ -501,22 +525,17 @@ (failWith CannotMixGADTConsWith98Cons) ; unless (isNothing ksig || isGadtDecl) (failWith KindSigsOnlyAllowedOnGADTs) - ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM (cvtConstr con_name) constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_cType = Nothing - , dd_ctxt = mkHsContextMaybe ctxt' - , dd_kindSig = ksig' - , dd_cons = DataTypeCons type_data cons' - , dd_derivs = derivs' } - ; returnJustLA $ TyClD noExtField $ - DataDecl { tcdDExt = noAnn - , tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn } } + ; let first_datacon = + case firstDataDefnCon constrs of + Nothing -> panic "cvtDataDefnCons: empty list of constructors" + Just con -> con + first_datacon_name = + case get_cons_names first_datacon of + [] -> panic "cvtDataDefnCons: data constructor with no names" + c:_ -> c + ; mapM (cvtConstr first_datacon_name con_name) constrs } + ---------------- cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) @@ -569,7 +588,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 TH.BndrVis] -> CvtM ( LHsContext GhcPs , LocatedN RdrName , LHsQTyVars GhcPs) @@ -650,31 +669,32 @@ -- Data types --------------------------------------------------- -cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name - -> TH.Con -> CvtM (LConDecl GhcPs) +cvtConstr :: TH.Name -- ^ name of first constructor of parent type + -> (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name + -> TH.Con -> CvtM (LConDecl GhcPs) -cvtConstr con_name (NormalC c strtys) - = do { c' <- con_name c +cvtConstr _ do_con_name (NormalC c strtys) + = do { c' <- do_con_name c ; tys' <- mapM cvt_arg strtys ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } -cvtConstr con_name (RecC c varstrtys) - = do { c' <- con_name c - ; args' <- mapM cvt_id_arg varstrtys +cvtConstr parent_con do_con_name (RecC c varstrtys) + = do { c' <- do_con_name c + ; args' <- mapM (cvt_id_arg parent_con) varstrtys ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' ; returnLA con_decl } -cvtConstr con_name (InfixC st1 c st2) - = do { c' <- con_name c +cvtConstr _ do_con_name (InfixC st1 c st2) + = do { c' <- do_con_name c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (InfixCon (hsLinear st1') (hsLinear st2')) } -cvtConstr con_name (ForallC tvs ctxt con) +cvtConstr parent_con do_con_name (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; L _ con' <- cvtConstr con_name con + ; L _ con' <- cvtConstr parent_con do_con_name con ; returnLA $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = mkHsContextMaybe lcxt @@ -702,20 +722,20 @@ where all_tvs = tvs' ++ ex_tvs -cvtConstr con_name (GadtC c strtys ty) = case nonEmpty c of +cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of Nothing -> failWith GadtNoCons Just c -> do - { c' <- mapM con_name c + { c' <- mapM do_con_name c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} -cvtConstr con_name (RecGadtC c varstrtys ty) = case nonEmpty c of +cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of Nothing -> failWith RecGadtNoCons Just c -> do - { c' <- mapM con_name c + { c' <- mapM do_con_name c ; ty' <- cvtType ty - ; rec_flds <- mapM cvt_id_arg varstrtys + ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys ; lrec_flds <- returnLA rec_flds ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' } @@ -751,9 +771,10 @@ ss' = cvtSrcStrictness ss ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' } -cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) -cvt_id_arg (i, str, ty) - = do { L li i' <- vNameN i +cvt_id_arg :: TH.Name -- ^ parent constructor name + -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) +cvt_id_arg parent_con (i, str, ty) + = do { L li i' <- fldNameN (nameBase parent_con) i ; ty' <- cvt_arg (str,ty) ; returnLA $ ConDeclField { cd_fld_ext = noAnn @@ -782,8 +803,8 @@ -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess | callconv == TH.Prim || callconv == TH.JavaScript -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing - (CFunction (StaticTarget (SourceText from) - (mkFastString from) Nothing + (CFunction (StaticTarget (SourceText fromtxt) + fromtxt Nothing True))) | Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety') (mkFastString (TH.nameBase nm)) @@ -792,6 +813,7 @@ | otherwise -> failWith $ InvalidCCallImpent from } where + fromtxt = mkFastString from mk_imp impspec = do { nm' <- vNameN nm ; ty' <- cvtSigType ty @@ -809,8 +831,9 @@ = do { nm' <- vNameN nm ; ty' <- cvtSigType ty ; l <- getL - ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as) - (mkFastString as) + ; let astxt = mkFastString as + ; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt) + astxt (cvt_conv callconv))) ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' @@ -830,11 +853,14 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) cvtPragmaD (InlineP nm inline rm phases) - = do { nm' <- vNameN nm + = do { -- NB: Use vcNameN here, which works for both the variable namespace + -- (e.g., `INLINE`d functions) and the constructor namespace + -- (e.g., `INLINE`d pattern synonyms, cf. #23203) + nm' <- vcNameN nm ; let dflt = dfltActivation inline - ; let src TH.NoInline = "{-# NOINLINE" - src TH.Inline = "{-# INLINE" - src TH.Inlinable = "{-# INLINABLE" + ; let src TH.NoInline = fsLit "{-# NOINLINE" + src TH.Inline = fsLit "{-# INLINE" + src TH.Inlinable = fsLit "{-# INLINABLE" ; let ip = InlinePragma { inl_src = toSrcTxt inline , inl_inline = cvtInline inline (toSrcTxt inline) , inl_rule = cvtRuleMatch rm @@ -852,20 +878,20 @@ , inl_act = NeverActive , inl_sat = Nothing } where - srcTxt = SourceText "{-# OPAQUE" + srcTxt = SourceText $ fsLit "{-# OPAQUE" ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameN nm ; ty' <- cvtSigType ty - ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" - src TH.Inline = "{-# SPECIALISE INLINE" - src TH.Inlinable = "{-# SPECIALISE INLINE" + ; let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE" + src TH.Inline = fsLit "{-# SPECIALISE INLINE" + src TH.Inlinable = fsLit "{-# SPECIALISE INLINE" ; let (inline', dflt, srcText) = case inline of Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1, toSrcTxt inline1) Nothing -> (NoUserInlinePrag, AlwaysActive, - SourceText "{-# SPECIALISE") + SourceText $ fsLit "{-# SPECIALISE") where toSrcTxt a = SourceText $ src a ; let ip = InlinePragma { inl_src = srcText @@ -878,7 +904,7 @@ cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtSigType ty ; returnJustLA $ Hs.SigD noExtField $ - SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' } + SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' } cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -897,7 +923,7 @@ , rd_lhs = lhs' , rd_rhs = rhs' } ; returnJustLA $ Hs.RuleD noExtField - $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES") + $ HsRules { rds_ext = (noAnn, SourceText $ fsLit "{-# RULES") , rds_rules = [rule] } } @@ -913,7 +939,7 @@ n' <- vcName n wrapParLA ValueAnnProvenance n' ; returnJustLA $ Hs.AnnD noExtField - $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp' + $ HsAnnotation (noAnn, (SourceText $ fsLit "{-# ANN")) target' exp' } -- NB: This is the only place in GHC.ThToHs that makes use of the `setL` @@ -1116,7 +1142,10 @@ ; flds' <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc)) flds - ; return $ RecordUpd noAnn e' (Left flds') } + ; return $ RecordUpd noAnn e' $ + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = flds' } } cvt (StaticE e) = fmap (HsStatic noAnn) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- important, because UnboundVarE may contain @@ -1130,6 +1159,10 @@ (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) } cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs + cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e + ; return $ HsTypedSplice (noAnn, noAnn) e' } + cvt (TypedBracketE e) = do { e' <- cvtl e + ; return $ HsTypedBracket noAnn e' } {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: @@ -1374,7 +1407,7 @@ -- "GHC.ThToHs", hence panic quotedSourceText :: String -> SourceText -quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" +quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\"" cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] cvtPats pats = mapM cvtPat pats @@ -1443,8 +1476,7 @@ ; return $ ListPat noAnn ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; let pp = parenthesizePat sigPrec p' - ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } + ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noAnn e' p'} @@ -1490,6 +1522,10 @@ cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec cvtFlag TH.InferredSpec = Hs.InferredSpec +instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where + cvtFlag TH.BndrReq = HsBndrRequired + cvtFlag TH.BndrInvis = HsBndrInvisible noHsTok + cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] cvtTvs tvs = mapM cvt_tv tvs @@ -1797,8 +1833,9 @@ case arg of HsValArg ty -> do p_ty <- add_parens ty mk_apps (HsAppTy noExtField phead_ty p_ty) args - HsTypeArg l ki -> do p_ki <- add_parens ki - mk_apps (HsAppKindTy l phead_ty p_ki) args + HsTypeArg at ki -> + do p_ki <- add_parens ki + mk_apps (HsAppKindTy noExtField phead_ty at p_ki) args HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args go type_args @@ -1843,7 +1880,7 @@ where go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } go (AppKindT ty ki) as' = do { ki' <- cvtKind ki - ; go ty (HsTypeArg noSrcSpan ki':as') } + ; go ty (HsTypeArg noHsTok ki' : as') } go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) @@ -2053,6 +2090,13 @@ tconNameN n = wrapLN (tconName n) tconName n = cvtName OccName.tcClsName n +-- Field names +fldName :: String -> TH.Name -> CvtM RdrName +fldName con n = cvtName (OccName.fieldName $ fsLit con) n + +fldNameN :: String -> TH.Name -> CvtM (LocatedN RdrName) +fldNameN con n = wrapLN (fldName con n) + ipName :: String -> CvtM HsIPName ipName n = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n)) @@ -2132,18 +2176,21 @@ where -- guessed_ns are the name spaces guessed from looking at the TH name guessed_nss - | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] - | otherwise = [OccName.varName, OccName.tvName] + | isLexCon occ_txt = [OccName.tcName, OccName.dataName] + | isLexVarSym occ_txt = [OccName.tcName, OccName.varName] -- #23525 + | otherwise = [OccName.varName, OccName.tvName] occ_str = TH.occString occ + occ_txt = mkFastString occ_str -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName mk_occ ns occ = OccName.mkOccName ns occ mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace -mk_ghc_ns TH.DataName = OccName.dataName -mk_ghc_ns TH.TcClsName = OccName.tcClsName -mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns (TH.FldName con) = OccName.fieldName (fsLit con) mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) @@ -2151,7 +2198,7 @@ mk_pkg :: TH.PkgName -> Unit mk_pkg pkg = stringToUnit (TH.pkgString pkg) -mk_uniq :: Word64 -> Unique +mk_uniq :: Int -> Unique mk_uniq u = mkUniqueGrimily u {- 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 @@ -17,16 +17,14 @@ import GHC.Unit.Module -import GHC.Types.Unique.FM import GHC.Types.Avail -import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Tc.Utils.Monad import GHC.Iface.Env +import GHC.Tc.Errors.Types -import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import Control.Monad @@ -87,7 +85,7 @@ mkNameShape mod_name as = NameShape mod_name as $ mkOccEnv $ do a <- as - n <- availName a : availNamesWithSelectors a + n <- availName a : availNames a return (occName n, n) -- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's @@ -106,7 +104,7 @@ -- restricted notion of shaping than in Backpack'14: we do shaping -- *as* we do type-checking. Thus, once we shape a signature, its -- exports are *final* and we're not allowed to refine them further, -extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape) +extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either HsigShapeMismatchReason NameShape) extendNameShape hsc_env ns as = case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of Left err -> return (Left err) @@ -180,24 +178,14 @@ -- for type constructors, where it is sufficient to substitute the 'availName' -- to induce a substitution on 'availNames'. substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo -substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n))) -substNameAvailInfo _ env (Avail (FieldGreName fl)) = - return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) })) +substNameAvailInfo _ env (Avail gre) = + return $ Avail (substName env gre) substNameAvailInfo hsc_env env (AvailTC n ns) = let mb_mod = fmap nameModule (lookupNameEnv env n) - in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns - -setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName -setNameGreName hsc_env mb_mod gname = case gname of - NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n) - FieldGreName fl -> FieldGreName <$> setNameFieldSelector hsc_env mb_mod fl + in AvailTC (substName env n) <$> mapM (setName hsc_env mb_mod) ns --- | Set the 'Module' of a 'FieldSelector' -setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel -setNameFieldSelector _ Nothing f = return f -setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do - sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel - return (FieldLabel l b has_sel sel') +setName :: HscEnv -> Maybe Module -> Name -> IO Name +setName hsc_env mb_mod nm = initIfaceLoad hsc_env (setNameModule mb_mod nm) {- ************************************************************************ @@ -224,46 +212,39 @@ -- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst +uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either HsigShapeMismatchReason ShNameSubst uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ - let mkOE as = listToUFM $ do a <- as - n <- availNames a - return (nameOccName n, a) + let mkOE as = mkOccEnv [(nameOccName n, a) | a <- as, n <- availNames a] in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv - (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) + (nonDetOccEnvElts $ intersectOccEnv_C (,) (mkOE as1) (mkOE as2)) -- Edward: I have to say, this is pretty clever. -- | Unify two 'AvailInfo's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo - -> Either SDoc ShNameSubst -uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2 -uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2 -uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" - <+> ppr a1 <+> text "with" <+> ppr a2 - <+> parens (text "one is a type, the other is a plain identifier") + -> Either HsigShapeMismatchReason ShNameSubst +uAvailInfo flexi subst (Avail n1) (Avail n2) + = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) + = uName flexi subst n1 n2 +uAvailInfo _ _ a1 a2 = Left $ HsigShapeSortMismatch a1 a2 -- | Unify two 'Name's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst +uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either HsigShapeMismatchReason ShNameSubst uName flexi subst n1 n2 | n1 == n2 = Right subst | isFlexi n1 = uHoleName flexi subst n1 n2 | isFlexi n2 = uHoleName flexi subst n2 n1 - | otherwise = Left (text "While merging export lists, could not unify" - <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra) + | otherwise = Left (HsigShapeNotUnifiable n1 n2 (isHoleName n1 || isHoleName n2)) where isFlexi n = isHoleName n && moduleName (nameModule n) == flexi - extra | isHoleName n1 || isHoleName n2 - = text "Neither name variable originates from the current signature." - | otherwise - = empty -- | Unify a name @h@ which 'isHoleName' with another name, given an existing -- substitution @subst@, with only name holes from @flexi@ unifiable (all -- other name holes rigid.) uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name - -> Either SDoc ShNameSubst + -> Either HsigShapeMismatchReason ShNameSubst uHoleName flexi subst h n = assert (isHoleName h) $ case lookupNameEnv subst h of diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs deleted file mode 100644 --- a/compiler/GHC/Types/TyThing/Ppr.hs +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------ --- --- Pretty-printing TyThings --- --- (c) The GHC Team 2005 --- ------------------------------------------------------------------------------ - - -module GHC.Types.TyThing.Ppr ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, - pprFamInst - ) where - -import GHC.Prelude - -import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) -import GHC.Types.Name - -import GHC.Core.Type ( ForAllTyFlag(..), mkTyVarBinders ) -import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) -import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) -import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) - -import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) - , showToHeader, pprIfaceDecl ) -import GHC.Iface.Make ( tyThingToIfaceDecl ) - -import GHC.Utils.Outputable - -import Data.Maybe ( isJust ) - --- ----------------------------------------------------------------------------- --- Pretty-printing entities that we get from the GHC API - -{- Note [Pretty printing via Iface syntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our general plan for pretty-printing - - Types - - TyCons - - Classes - - Pattern synonyms - ...etc... - -is to convert them to Iface syntax, and pretty-print that. For example - - pprType converts a Type to an IfaceType, and pretty prints that. - - pprTyThing converts the TyThing to an IfaceDecl, - and pretty prints that. - -So Iface syntax plays a dual role: - - it's the internal version of an interface files - - it's used for pretty-printing - -Why do this? - -* A significant reason is that we need to be able - to pretty-print Iface syntax (to display Foo.hi), and it was a - pain to duplicate masses of pretty-printing goop, esp for - Type and IfaceType. - -* When pretty-printing (a type, say), we want to tidy (with - tidyType) to avoids having (forall a a. blah) where the two - a's have different uniques. - - Alas, for type constructors, TyCon, tidying does not work well, - because a TyCon includes DataCons which include Types, which mention - TyCons. And tidying can't tidy a mutually recursive data structure - graph, only trees. - -* Interface files contains fast-strings, not uniques, so the very same - tidying must take place when we convert to IfaceDecl. E.g. - GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon, - Class etc) to an IfaceDecl. - - Bottom line: IfaceDecls are already 'tidy', so it's straightforward - to print them. - -* An alternative I once explored was to ensure that TyCons get type - variables with distinct print-names. That's ok for type variables - but less easy for kind variables. Processing data type declarations - is already so complicated that I don't think it's sensible to add - the extra requirement that it generates only "pretty" types and - kinds. - -Consequences: - -- Iface syntax (and IfaceType) must contain enough information to - print nicely. Hence, for example, the IfaceAppArgs type, which - allows us to suppress invisible kind arguments in types - (see Note [Suppressing invisible arguments] in GHC.Iface.Type) - -- In a few places we have info that is used only for pretty-printing, - and is totally ignored when turning Iface syntax back into Core - (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon - stores a [IfaceAxBranch] that is used only for pretty-printing. - -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type - -See #7730, #8776 for details -} - --------------------- --- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. -pprFamInst :: FamInst -> SDoc --- * For data instances we go via pprTyThing of the representational TyCon, --- because there is already much cleverness associated with printing --- data type declarations that I don't want to duplicate --- * For type instances we print directly here; there is no TyCon --- to give to pprTyThing --- --- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes - -pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) - = pprTyThingInContextLoc (ATyCon rep_tc) - -pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom - , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs }) - = showWithLoc (pprDefinedAt (getName axiom)) $ - hang (text "type instance" - <+> pprUserForAll (mkTyVarBinders Specified tvs) - -- See Note [Printing foralls in type family instances] - -- in GHC.Iface.Type - <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) - 2 (equals <+> ppr rhs) - ----------------------------- --- | Pretty-prints a 'TyThing' with its defining location. -pprTyThingLoc :: TyThing -> SDoc -pprTyThingLoc tyThing - = showWithLoc (pprDefinedAt (getName tyThing)) - (pprTyThing showToHeader tyThing) - --- | Pretty-prints the 'TyThing' header. For functions and data constructors --- the function is equivalent to 'pprTyThing' but for type constructors --- and classes it prints only the header part of the declaration. -pprTyThingHdr :: TyThing -> SDoc -pprTyThingHdr = pprTyThing showToHeader - --- | Pretty-prints a 'TyThing' in context: that is, if the entity --- is a data constructor, record selector, or class method, then --- the entity's parent declaration is pretty-printed with irrelevant --- parts omitted. -pprTyThingInContext :: ShowSub -> TyThing -> SDoc -pprTyThingInContext show_sub thing - = go [] thing - where - go ss thing - = case tyThingParent_maybe thing of - Just parent -> - go (getOccName thing : ss) parent - Nothing -> - pprTyThing - (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) }) - thing - --- | Like 'pprTyThingInContext', but adds the defining location. -pprTyThingInContextLoc :: TyThing -> SDoc -pprTyThingInContextLoc tyThing - = showWithLoc (pprDefinedAt (getName tyThing)) - (pprTyThingInContext showToHeader tyThing) - --- | Pretty-prints a 'TyThing'. -pprTyThing :: ShowSub -> TyThing -> SDoc --- We pretty-print 'TyThing' via 'IfaceDecl' --- See Note [Pretty printing via Iface syntax] -pprTyThing ss ty_thing - = sdocOption sdocLinearTypes $ \show_linear_types -> - pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing) - where - ss' = case ss_how_much ss of - ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } - ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' } - _ -> ss - - ppr' = AltPpr $ ppr_bndr $ getName ty_thing - - ppr_bndr :: Name -> Maybe (OccName -> SDoc) - ppr_bndr name - | isBuiltInSyntax name || isJust (namePun_maybe name) - = Nothing - | otherwise - = case nameModule_maybe name of - Just mod -> Just $ \occ -> getPprStyle $ \sty -> - pprModulePrefix sty mod occ <> ppr occ - Nothing -> warnPprTrace True "pprTyThing" (ppr name) Nothing - -- Nothing is unexpected here; TyThings have External names - -showWithLoc :: SDoc -> SDoc -> SDoc -showWithLoc loc doc - = hang doc 2 (char '\t' <> comment <+> loc) - -- The tab tries to make them line up a bit - where - comment = text "--" diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -301,7 +301,7 @@ , fr_suggestions = [] }) LookupUnusable unusable -> let unusables' = map get_unusable unusable - get_unusable (_, ModUnusable r) = r + get_unusable (m, ModUnusable r) = (moduleUnit m, r) get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in return (NotFound{ fr_paths = [], fr_pkg = Nothing diff --git a/compiler/GHC/Utils/Monad/Codensity.hs b/compiler/GHC/Utils/Monad/Codensity.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Utils/Monad/Codensity.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module GHC.Utils.Monad.Codensity + ( Codensity(..), toCodensity, fromCodensity ) + where + +import Data.Kind ( Type ) + +import GHC.Prelude +import GHC.Exts ( oneShot ) + +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Concurrent.MVar ( newEmptyMVar, readMVar, putMVar ) +import Control.Exception +import GHC.IO.Exception +import GHC.IO.Unsafe ( unsafeDupableInterleaveIO ) + +-------------------------------------------------------------------------------- + +type Codensity :: (Type -> Type) -> Type -> Type +newtype Codensity m a = Codensity { runCodensity :: forall r. (a -> m r) -> m r } +instance Functor (Codensity k) where + fmap f (Codensity m) = Codensity $ oneShot (\k -> m $ oneShot (\x -> k $ f x)) + {-# INLINE fmap #-} +instance Applicative (Codensity f) where + pure x = Codensity $ oneShot (\k -> k x) + {-# INLINE pure #-} + Codensity f <*> Codensity g = + Codensity $ oneShot (\bfr -> f $ oneShot (\ab -> g $ oneShot (\x -> bfr (ab x)))) + {-# INLINE (<*>) #-} +instance Monad (Codensity f) where + return = pure + {-# INLINE return #-} + m >>= k = + Codensity $ oneShot (\c -> runCodensity m $ oneShot (\a -> runCodensity (k a) c)) + {-# INLINE (>>=) #-} +instance MonadTrans Codensity where + lift m = Codensity $ oneShot (m >>=) + {-# INLINE lift #-} +instance MonadIO m => MonadIO (Codensity m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} +instance MonadIO m => MonadFix (Codensity m) where + mfix f = Codensity $ oneShot $ \ k -> do + promise <- liftIO $ newEmptyMVar + ans <- liftIO $ unsafeDupableInterleaveIO + $ readMVar promise + `catch` + (\ BlockedIndefinitelyOnMVar -> throwIO FixIOException) + runCodensity (f ans) $ oneShot $ \ a -> do + liftIO $ putMVar promise a + k a + {-# INLINE mfix #-} + +toCodensity :: Monad m => m a -> Codensity m a +toCodensity m = Codensity $ oneShot (m >>=) +{-# INLINE toCodensity #-} + +fromCodensity :: Monad m => Codensity m a -> m a +fromCodensity c = runCodensity c return +{-# INLINE fromCodensity #-} diff --git a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs --- a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs +++ b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs @@ -19,12 +19,13 @@ import GHC.Cmm.Dominators import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Reducibility import GHC.Cmm.Switch import GHC.CmmToAsm.Wasm.Types import GHC.Platform - +import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr @@ -78,7 +79,7 @@ scrutinee = smartExtend platform $ smartPlus platform e offset range = inclusiveInterval (lo+toInteger offset) (hi+toInteger offset) in Switch scrutinee range target_labels default_label - CmmCall { cml_cont = Nothing, cml_target = e } -> TailCall e + CmmCall { cml_target = e } -> TailCall e _ -> panic "flowLeaving: unreachable" ----------------------- Evaluation contexts ------------------------------ @@ -140,15 +141,19 @@ structuredControl :: forall expr stmt m . Applicative m => Platform -- ^ needed for offset calculation + -> UniqSupply -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code -> CmmGraph -- ^ CFG to be translated -> m (WasmControl stmt expr '[] '[ 'I32]) -structuredControl platform txExpr txBlock g = +structuredControl platform us txExpr txBlock g' = doTree returns dominatorTree emptyContext where + g :: CmmGraph + g = gwd_graph gwd + gwd :: GraphWithDominators CmmNode - gwd = graphWithDominators g + gwd = initUs_ us $ asReducible $ graphWithDominators g' dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted -- with highest reverse-postorder number first diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,8 +1,8 @@ -cabal-version: 3.0 +cabal-version: 2.0 build-type: Simple name: ghc-lib -version: 9.6.7.20250325 -license: BSD-3-Clause +version: 9.8.1.20231009 +license: BSD3 license-file: LICENSE category: Development author: The GHC Team and Digital Asset @@ -37,7 +37,7 @@ ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl ghc-lib/stage0/compiler/build/primop-docs.hs-incl ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs - compiler/ghc-llvm-version.h + libraries/containers/containers/include/containers.h rts/include/ghcconfig.h compiler/MachRegs.h compiler/CodeGen.Platform.h @@ -45,6 +45,7 @@ compiler/ClosureTypes.h compiler/FunTypes.h compiler/Unique.h + compiler/ghc-llvm-version.h source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git @@ -53,15 +54,14 @@ manual: True description: Pass -DTHREADED_RTS to the C toolchain library - default-language: Haskell2010 + default-language: Haskell2010 exposed: False include-dirs: rts/include ghc-lib/stage0/lib ghc-lib/stage0/compiler/build compiler - if impl(ghc >= 8.8.1) - ghc-options: -fno-safe-haskell + libraries/containers/containers/include if flag(threaded-rts) ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS @@ -74,15 +74,15 @@ else build-depends: Win32 build-depends: - base >= 4.16.1 && < 4.19, - ghc-prim > 0.2 && < 0.11, + base >= 4.17.0.0 && < 4.20, + ghc-prim > 0.2 && < 0.12, containers >= 0.6.2.1 && < 0.7, - bytestring >= 0.11.3 && < 0.12, + bytestring >= 0.11.4 && < 0.12, time >= 1.4 && < 1.13, - filepath >= 1 && < 1.5, exceptions == 0.10.*, parsec, binary == 0.8.*, + filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.6, @@ -90,10 +90,11 @@ transformers >= 0.5 && < 0.7, process >= 1 && < 1.7, stm, + semaphore-compat, rts, - hpc >= 0.6 && < 0.8, - ghc-lib-parser == 9.6.7.20250325 - build-tool-depends: alex:alex >= 3.1, happy:happy < 1.21 + hpc == 0.6.*, + ghc-lib-parser == 9.8.1.20231009 + build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns CPP @@ -137,6 +138,7 @@ hs-source-dirs: ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/compiler/build + libraries/ghci compiler autogen-modules: Paths_ghc_lib @@ -182,12 +184,14 @@ GHC.Core.Multiplicity, GHC.Core.Opt.Arity, GHC.Core.Opt.CallerCC, + GHC.Core.Opt.CallerCC.Types, GHC.Core.Opt.ConstantFold, GHC.Core.Opt.Monad, GHC.Core.Opt.OccurAnal, GHC.Core.Opt.Pipeline.Types, GHC.Core.Opt.Simplify, GHC.Core.Opt.Simplify.Env, + GHC.Core.Opt.Simplify.Inline, GHC.Core.Opt.Simplify.Iteration, GHC.Core.Opt.Simplify.Monad, GHC.Core.Opt.Simplify.Utils, @@ -244,13 +248,6 @@ GHC.Data.StringBuffer, GHC.Data.TrieMap, GHC.Data.Unboxed, - GHC.Data.Word64Map, - GHC.Data.Word64Map.Internal, - GHC.Data.Word64Map.Lazy, - GHC.Data.Word64Map.Strict, - GHC.Data.Word64Map.Strict.Internal, - GHC.Data.Word64Set, - GHC.Data.Word64Set.Internal, GHC.Driver.Backend, GHC.Driver.Backend.Internal, GHC.Driver.Backpack.Syntax, @@ -260,6 +257,7 @@ GHC.Driver.Config.Diagnostic, GHC.Driver.Config.Logger, GHC.Driver.Config.Parser, + GHC.Driver.DynFlags, GHC.Driver.Env, GHC.Driver.Env.KnotVars, GHC.Driver.Env.Types, @@ -313,10 +311,18 @@ GHC.HsToCore.Pmc.Ppr, GHC.HsToCore.Pmc.Solver.Types, GHC.HsToCore.Pmc.Types, + GHC.Iface.Decl, + GHC.Iface.Errors.Ppr, + GHC.Iface.Errors.Types, GHC.Iface.Ext.Fields, GHC.Iface.Recomp.Binary, GHC.Iface.Syntax, GHC.Iface.Type, + GHC.JS.Make, + GHC.JS.Ppr, + GHC.JS.Syntax, + GHC.JS.Transform, + GHC.JS.Unsat.Syntax, GHC.LanguageExtensions, GHC.LanguageExtensions.Type, GHC.Lexeme, @@ -357,7 +363,6 @@ GHC.Runtime.Context, GHC.Runtime.Eval.Types, GHC.Runtime.Heap.Layout, - GHC.Runtime.Interpreter, GHC.Runtime.Interpreter.Types, GHC.Serialized, GHC.Settings, @@ -365,22 +370,35 @@ GHC.Settings.Constants, GHC.Settings.Utils, GHC.Stg.InferTags.TagSig, + GHC.Stg.Lift.Types, GHC.Stg.Syntax, GHC.StgToCmm.Config, GHC.StgToCmm.Types, + GHC.StgToJS.Linker.Types, + GHC.StgToJS.Object, + GHC.StgToJS.Types, GHC.SysTools.BaseDir, GHC.SysTools.Terminal, GHC.Tc.Errors.Hole.FitTypes, + GHC.Tc.Errors.Hole.Plugin, GHC.Tc.Errors.Ppr, GHC.Tc.Errors.Types, + GHC.Tc.Errors.Types.PromotionErr, GHC.Tc.Solver.InertSet, GHC.Tc.Solver.Types, GHC.Tc.Types, + GHC.Tc.Types.BasicTypes, GHC.Tc.Types.Constraint, + GHC.Tc.Types.CtLocEnv, + GHC.Tc.Types.ErrCtxt, GHC.Tc.Types.Evidence, + GHC.Tc.Types.LclEnv, GHC.Tc.Types.Origin, GHC.Tc.Types.Rank, + GHC.Tc.Types.TH, + GHC.Tc.Types.TcRef, GHC.Tc.Utils.TcType, + GHC.Tc.Zonk.Monad, GHC.Types.Annotations, GHC.Types.Avail, GHC.Types.Basic, @@ -397,6 +415,7 @@ GHC.Types.Fixity.Env, GHC.Types.ForeignCall, GHC.Types.ForeignStubs, + GHC.Types.GREInfo, GHC.Types.Hint, GHC.Types.Hint.Ppr, GHC.Types.HpcInfo, @@ -417,6 +436,7 @@ GHC.Types.ProfAuto, GHC.Types.RepType, GHC.Types.SafeHaskell, + GHC.Types.SaneDouble, GHC.Types.SourceError, GHC.Types.SourceFile, GHC.Types.SourceText, @@ -424,6 +444,7 @@ GHC.Types.Target, GHC.Types.Tickish, GHC.Types.TyThing, + GHC.Types.TyThing.Ppr, GHC.Types.TypeEnv, GHC.Types.Unique, GHC.Types.Unique.DFM, @@ -467,8 +488,6 @@ GHC.Utils.BufHandle, GHC.Utils.CliOption, GHC.Utils.Constants, - GHC.Utils.Containers.Internal.BitUtil, - GHC.Utils.Containers.Internal.StrictPair, GHC.Utils.Encoding, GHC.Utils.Encoding.UTF8, GHC.Utils.Error, @@ -490,15 +509,11 @@ GHC.Utils.Ppr.Colour, GHC.Utils.TmpFs, GHC.Utils.Trace, - GHC.Utils.Unique, - GHC.Utils.Word64, GHC.Version, - GHCi.BinaryArray, GHCi.BreakArray, GHCi.FFI, GHCi.Message, GHCi.RemoteTypes, - GHCi.ResolvedBCO, GHCi.TH.Binary, Language.Haskell.Syntax, Language.Haskell.Syntax.Basic, @@ -553,6 +568,7 @@ GHC.Cmm.Parser.Monad GHC.Cmm.Pipeline GHC.Cmm.ProcPoint + GHC.Cmm.Reducibility GHC.Cmm.Sink GHC.Cmm.Switch.Implement GHC.Cmm.ThreadSanitizer @@ -648,7 +664,10 @@ GHC.CoreToStg.Prep GHC.Data.Bitmap GHC.Data.Graph.Base + GHC.Data.Graph.Collapse GHC.Data.Graph.Color + GHC.Data.Graph.Inductive.Graph + GHC.Data.Graph.Inductive.PatriciaTree GHC.Data.Graph.Ops GHC.Data.Graph.Ppr GHC.Data.UnionFind @@ -680,6 +699,7 @@ GHC.Driver.GenerateCgIPEStub GHC.Driver.Main GHC.Driver.Make + GHC.Driver.MakeSem GHC.Driver.Pipeline GHC.Driver.Pipeline.Execute GHC.Driver.Pipeline.LogQueue @@ -730,11 +750,9 @@ GHC.Iface.Tidy GHC.Iface.Tidy.StaticPtrTable GHC.IfaceToCore - GHC.JS.Make - GHC.JS.Ppr - GHC.JS.Syntax - GHC.JS.Transform + GHC.JS.Optimizer GHC.Linker.Config + GHC.Linker.Deps GHC.Linker.Dynamic GHC.Linker.ExtraObj GHC.Linker.Loader @@ -764,7 +782,11 @@ GHC.Rename.Utils GHC.Runtime.Eval GHC.Runtime.Heap.Inspect + GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.JS + GHC.Runtime.Interpreter.Process GHC.Runtime.Loader + GHC.Runtime.Utils GHC.Settings.IO GHC.Stg.BcPrep GHC.Stg.CSE @@ -811,7 +833,6 @@ GHC.StgToJS.Arg GHC.StgToJS.Closure GHC.StgToJS.CodeGen - GHC.StgToJS.CoreUtils GHC.StgToJS.DataCon GHC.StgToJS.Deps GHC.StgToJS.Expr @@ -820,13 +841,11 @@ GHC.StgToJS.Heap GHC.StgToJS.Ids GHC.StgToJS.Linker.Linker - GHC.StgToJS.Linker.Types + GHC.StgToJS.Linker.Opt GHC.StgToJS.Linker.Utils GHC.StgToJS.Literal GHC.StgToJS.Monad - GHC.StgToJS.Object GHC.StgToJS.Prim - GHC.StgToJS.Printer GHC.StgToJS.Profiling GHC.StgToJS.Regs GHC.StgToJS.Rts.Rts @@ -834,9 +853,7 @@ GHC.StgToJS.Sinker GHC.StgToJS.Stack GHC.StgToJS.StaticPtr - GHC.StgToJS.StgUtils GHC.StgToJS.Symbols - GHC.StgToJS.Types GHC.StgToJS.Utils GHC.SysTools GHC.SysTools.Ar @@ -874,10 +891,12 @@ GHC.Tc.Instance.Typeable GHC.Tc.Module GHC.Tc.Solver - GHC.Tc.Solver.Canonical - GHC.Tc.Solver.Interact + GHC.Tc.Solver.Dict + GHC.Tc.Solver.Equality + GHC.Tc.Solver.Irred GHC.Tc.Solver.Monad GHC.Tc.Solver.Rewrite + GHC.Tc.Solver.Solve GHC.Tc.TyCl GHC.Tc.TyCl.Build GHC.Tc.TyCl.Class @@ -892,13 +911,17 @@ GHC.Tc.Utils.Monad GHC.Tc.Utils.TcMType GHC.Tc.Utils.Unify - GHC.Tc.Utils.Zonk GHC.Tc.Validity + GHC.Tc.Zonk.Env + GHC.Tc.Zonk.TcType + GHC.Tc.Zonk.Type GHC.ThToHs GHC.Types.Name.Shape - GHC.Types.TyThing.Ppr GHC.Types.Unique.MemoFun GHC.Unit.Finder GHC.Utils.Asm + GHC.Utils.Monad.Codensity GHC.Wasm.ControlFlow GHC.Wasm.ControlFlow.FromCmm + GHCi.BinaryArray + GHCi.ResolvedBCO 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 @@ -66,12 +66,12 @@ primOpCanFail IndexByteArrayOp_Double = True primOpCanFail IndexByteArrayOp_StablePtr = True primOpCanFail IndexByteArrayOp_Int8 = True -primOpCanFail IndexByteArrayOp_Int16 = True -primOpCanFail IndexByteArrayOp_Int32 = True -primOpCanFail IndexByteArrayOp_Int64 = True primOpCanFail IndexByteArrayOp_Word8 = True +primOpCanFail IndexByteArrayOp_Int16 = True primOpCanFail IndexByteArrayOp_Word16 = True +primOpCanFail IndexByteArrayOp_Int32 = True primOpCanFail IndexByteArrayOp_Word32 = True +primOpCanFail IndexByteArrayOp_Int64 = True primOpCanFail IndexByteArrayOp_Word64 = True primOpCanFail IndexByteArrayOp_Word8AsChar = True primOpCanFail IndexByteArrayOp_Word8AsWideChar = True @@ -82,10 +82,10 @@ primOpCanFail IndexByteArrayOp_Word8AsDouble = True primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True primOpCanFail IndexByteArrayOp_Word8AsInt16 = True -primOpCanFail IndexByteArrayOp_Word8AsInt32 = True -primOpCanFail IndexByteArrayOp_Word8AsInt64 = True primOpCanFail IndexByteArrayOp_Word8AsWord16 = True +primOpCanFail IndexByteArrayOp_Word8AsInt32 = True primOpCanFail IndexByteArrayOp_Word8AsWord32 = True +primOpCanFail IndexByteArrayOp_Word8AsInt64 = True primOpCanFail IndexByteArrayOp_Word8AsWord64 = True primOpCanFail ReadByteArrayOp_Char = True primOpCanFail ReadByteArrayOp_WideChar = True @@ -96,12 +96,12 @@ primOpCanFail ReadByteArrayOp_Double = True primOpCanFail ReadByteArrayOp_StablePtr = True primOpCanFail ReadByteArrayOp_Int8 = True -primOpCanFail ReadByteArrayOp_Int16 = True -primOpCanFail ReadByteArrayOp_Int32 = True -primOpCanFail ReadByteArrayOp_Int64 = True primOpCanFail ReadByteArrayOp_Word8 = True +primOpCanFail ReadByteArrayOp_Int16 = True primOpCanFail ReadByteArrayOp_Word16 = True +primOpCanFail ReadByteArrayOp_Int32 = True primOpCanFail ReadByteArrayOp_Word32 = True +primOpCanFail ReadByteArrayOp_Int64 = True primOpCanFail ReadByteArrayOp_Word64 = True primOpCanFail ReadByteArrayOp_Word8AsChar = True primOpCanFail ReadByteArrayOp_Word8AsWideChar = True @@ -112,10 +112,10 @@ primOpCanFail ReadByteArrayOp_Word8AsDouble = True primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True primOpCanFail ReadByteArrayOp_Word8AsInt16 = True -primOpCanFail ReadByteArrayOp_Word8AsInt32 = True -primOpCanFail ReadByteArrayOp_Word8AsInt64 = True primOpCanFail ReadByteArrayOp_Word8AsWord16 = True +primOpCanFail ReadByteArrayOp_Word8AsInt32 = True primOpCanFail ReadByteArrayOp_Word8AsWord32 = True +primOpCanFail ReadByteArrayOp_Word8AsInt64 = True primOpCanFail ReadByteArrayOp_Word8AsWord64 = True primOpCanFail WriteByteArrayOp_Char = True primOpCanFail WriteByteArrayOp_WideChar = True @@ -126,12 +126,12 @@ primOpCanFail WriteByteArrayOp_Double = True primOpCanFail WriteByteArrayOp_StablePtr = True primOpCanFail WriteByteArrayOp_Int8 = True -primOpCanFail WriteByteArrayOp_Int16 = True -primOpCanFail WriteByteArrayOp_Int32 = True -primOpCanFail WriteByteArrayOp_Int64 = True primOpCanFail WriteByteArrayOp_Word8 = True +primOpCanFail WriteByteArrayOp_Int16 = True primOpCanFail WriteByteArrayOp_Word16 = True +primOpCanFail WriteByteArrayOp_Int32 = True primOpCanFail WriteByteArrayOp_Word32 = True +primOpCanFail WriteByteArrayOp_Int64 = True primOpCanFail WriteByteArrayOp_Word64 = True primOpCanFail WriteByteArrayOp_Word8AsChar = True primOpCanFail WriteByteArrayOp_Word8AsWideChar = True @@ -142,18 +142,22 @@ primOpCanFail WriteByteArrayOp_Word8AsDouble = True primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True primOpCanFail WriteByteArrayOp_Word8AsInt16 = True -primOpCanFail WriteByteArrayOp_Word8AsInt32 = True -primOpCanFail WriteByteArrayOp_Word8AsInt64 = True primOpCanFail WriteByteArrayOp_Word8AsWord16 = True +primOpCanFail WriteByteArrayOp_Word8AsInt32 = True primOpCanFail WriteByteArrayOp_Word8AsWord32 = True +primOpCanFail WriteByteArrayOp_Word8AsInt64 = True primOpCanFail WriteByteArrayOp_Word8AsWord64 = True primOpCanFail CompareByteArraysOp = True primOpCanFail CopyByteArrayOp = True primOpCanFail CopyMutableByteArrayOp = True +primOpCanFail CopyMutableByteArrayNonOverlappingOp = True primOpCanFail CopyByteArrayToAddrOp = True primOpCanFail CopyMutableByteArrayToAddrOp = True primOpCanFail CopyAddrToByteArrayOp = True +primOpCanFail CopyAddrToAddrOp = True +primOpCanFail CopyAddrToAddrNonOverlappingOp = True primOpCanFail SetByteArrayOp = True +primOpCanFail SetAddrRangeOp = True primOpCanFail AtomicReadByteArrayOp_Int = True primOpCanFail AtomicWriteByteArrayOp_Int = True primOpCanFail CasByteArrayOp_Int = True @@ -176,12 +180,12 @@ primOpCanFail IndexOffAddrOp_Double = True primOpCanFail IndexOffAddrOp_StablePtr = True primOpCanFail IndexOffAddrOp_Int8 = True -primOpCanFail IndexOffAddrOp_Int16 = True -primOpCanFail IndexOffAddrOp_Int32 = True -primOpCanFail IndexOffAddrOp_Int64 = True primOpCanFail IndexOffAddrOp_Word8 = True +primOpCanFail IndexOffAddrOp_Int16 = True primOpCanFail IndexOffAddrOp_Word16 = True +primOpCanFail IndexOffAddrOp_Int32 = True primOpCanFail IndexOffAddrOp_Word32 = True +primOpCanFail IndexOffAddrOp_Int64 = True primOpCanFail IndexOffAddrOp_Word64 = True primOpCanFail ReadOffAddrOp_Char = True primOpCanFail ReadOffAddrOp_WideChar = True @@ -192,12 +196,12 @@ primOpCanFail ReadOffAddrOp_Double = True primOpCanFail ReadOffAddrOp_StablePtr = True primOpCanFail ReadOffAddrOp_Int8 = True -primOpCanFail ReadOffAddrOp_Int16 = True -primOpCanFail ReadOffAddrOp_Int32 = True -primOpCanFail ReadOffAddrOp_Int64 = True primOpCanFail ReadOffAddrOp_Word8 = True +primOpCanFail ReadOffAddrOp_Int16 = True primOpCanFail ReadOffAddrOp_Word16 = True +primOpCanFail ReadOffAddrOp_Int32 = True primOpCanFail ReadOffAddrOp_Word32 = True +primOpCanFail ReadOffAddrOp_Int64 = True primOpCanFail ReadOffAddrOp_Word64 = True primOpCanFail WriteOffAddrOp_Char = True primOpCanFail WriteOffAddrOp_WideChar = True @@ -208,12 +212,12 @@ primOpCanFail WriteOffAddrOp_Double = True primOpCanFail WriteOffAddrOp_StablePtr = True primOpCanFail WriteOffAddrOp_Int8 = True -primOpCanFail WriteOffAddrOp_Int16 = True -primOpCanFail WriteOffAddrOp_Int32 = True -primOpCanFail WriteOffAddrOp_Int64 = True primOpCanFail WriteOffAddrOp_Word8 = True +primOpCanFail WriteOffAddrOp_Int16 = True primOpCanFail WriteOffAddrOp_Word16 = True +primOpCanFail WriteOffAddrOp_Int32 = True primOpCanFail WriteOffAddrOp_Word32 = True +primOpCanFail WriteOffAddrOp_Int64 = True primOpCanFail WriteOffAddrOp_Word64 = True primOpCanFail InterlockedExchange_Addr = True primOpCanFail InterlockedExchange_Word = True diff --git a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl @@ -54,10 +54,14 @@ primOpCodeSize WriteArrayOp = 2 primOpCodeSize CopyByteArrayOp = primOpCodeSizeForeignCall + 4 primOpCodeSize CopyMutableByteArrayOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyMutableByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyAddrToByteArrayOp = primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyMutableByteArrayNonOverlappingOp = primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyMutableByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyAddrToByteArrayOp = primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyAddrToAddrOp = primOpCodeSizeForeignCall +primOpCodeSize CopyAddrToAddrNonOverlappingOp = primOpCodeSizeForeignCall primOpCodeSize SetByteArrayOp = primOpCodeSizeForeignCall + 4 +primOpCodeSize SetAddrRangeOp = primOpCodeSizeForeignCall primOpCodeSize AddrToIntOp = 0 primOpCodeSize IntToAddrOp = 0 primOpCodeSize WriteMutVarOp = primOpCodeSizeForeignCall diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl @@ -325,6 +325,14 @@ | FloatPowerOp | FloatToDoubleOp | FloatDecode_IntOp + | FloatFMAdd + | FloatFMSub + | FloatFNMAdd + | FloatFNMSub + | DoubleFMAdd + | DoubleFMSub + | DoubleFNMAdd + | DoubleFNMSub | NewArrayOp | ReadArrayOp | WriteArrayOp @@ -379,12 +387,12 @@ | IndexByteArrayOp_Double | IndexByteArrayOp_StablePtr | IndexByteArrayOp_Int8 - | IndexByteArrayOp_Int16 - | IndexByteArrayOp_Int32 - | IndexByteArrayOp_Int64 | IndexByteArrayOp_Word8 + | IndexByteArrayOp_Int16 | IndexByteArrayOp_Word16 + | IndexByteArrayOp_Int32 | IndexByteArrayOp_Word32 + | IndexByteArrayOp_Int64 | IndexByteArrayOp_Word64 | IndexByteArrayOp_Word8AsChar | IndexByteArrayOp_Word8AsWideChar @@ -395,10 +403,10 @@ | IndexByteArrayOp_Word8AsDouble | IndexByteArrayOp_Word8AsStablePtr | IndexByteArrayOp_Word8AsInt16 - | IndexByteArrayOp_Word8AsInt32 - | IndexByteArrayOp_Word8AsInt64 | IndexByteArrayOp_Word8AsWord16 + | IndexByteArrayOp_Word8AsInt32 | IndexByteArrayOp_Word8AsWord32 + | IndexByteArrayOp_Word8AsInt64 | IndexByteArrayOp_Word8AsWord64 | ReadByteArrayOp_Char | ReadByteArrayOp_WideChar @@ -409,12 +417,12 @@ | ReadByteArrayOp_Double | ReadByteArrayOp_StablePtr | ReadByteArrayOp_Int8 - | ReadByteArrayOp_Int16 - | ReadByteArrayOp_Int32 - | ReadByteArrayOp_Int64 | ReadByteArrayOp_Word8 + | ReadByteArrayOp_Int16 | ReadByteArrayOp_Word16 + | ReadByteArrayOp_Int32 | ReadByteArrayOp_Word32 + | ReadByteArrayOp_Int64 | ReadByteArrayOp_Word64 | ReadByteArrayOp_Word8AsChar | ReadByteArrayOp_Word8AsWideChar @@ -425,10 +433,10 @@ | ReadByteArrayOp_Word8AsDouble | ReadByteArrayOp_Word8AsStablePtr | ReadByteArrayOp_Word8AsInt16 - | ReadByteArrayOp_Word8AsInt32 - | ReadByteArrayOp_Word8AsInt64 | ReadByteArrayOp_Word8AsWord16 + | ReadByteArrayOp_Word8AsInt32 | ReadByteArrayOp_Word8AsWord32 + | ReadByteArrayOp_Word8AsInt64 | ReadByteArrayOp_Word8AsWord64 | WriteByteArrayOp_Char | WriteByteArrayOp_WideChar @@ -439,12 +447,12 @@ | WriteByteArrayOp_Double | WriteByteArrayOp_StablePtr | WriteByteArrayOp_Int8 - | WriteByteArrayOp_Int16 - | WriteByteArrayOp_Int32 - | WriteByteArrayOp_Int64 | WriteByteArrayOp_Word8 + | WriteByteArrayOp_Int16 | WriteByteArrayOp_Word16 + | WriteByteArrayOp_Int32 | WriteByteArrayOp_Word32 + | WriteByteArrayOp_Int64 | WriteByteArrayOp_Word64 | WriteByteArrayOp_Word8AsChar | WriteByteArrayOp_Word8AsWideChar @@ -455,18 +463,22 @@ | WriteByteArrayOp_Word8AsDouble | WriteByteArrayOp_Word8AsStablePtr | WriteByteArrayOp_Word8AsInt16 - | WriteByteArrayOp_Word8AsInt32 - | WriteByteArrayOp_Word8AsInt64 | WriteByteArrayOp_Word8AsWord16 + | WriteByteArrayOp_Word8AsInt32 | WriteByteArrayOp_Word8AsWord32 + | WriteByteArrayOp_Word8AsInt64 | WriteByteArrayOp_Word8AsWord64 | CompareByteArraysOp | CopyByteArrayOp | CopyMutableByteArrayOp + | CopyMutableByteArrayNonOverlappingOp | CopyByteArrayToAddrOp | CopyMutableByteArrayToAddrOp | CopyAddrToByteArrayOp + | CopyAddrToAddrOp + | CopyAddrToAddrNonOverlappingOp | SetByteArrayOp + | SetAddrRangeOp | AtomicReadByteArrayOp_Int | AtomicWriteByteArrayOp_Int | CasByteArrayOp_Int @@ -500,12 +512,12 @@ | IndexOffAddrOp_Double | IndexOffAddrOp_StablePtr | IndexOffAddrOp_Int8 - | IndexOffAddrOp_Int16 - | IndexOffAddrOp_Int32 - | IndexOffAddrOp_Int64 | IndexOffAddrOp_Word8 + | IndexOffAddrOp_Int16 | IndexOffAddrOp_Word16 + | IndexOffAddrOp_Int32 | IndexOffAddrOp_Word32 + | IndexOffAddrOp_Int64 | IndexOffAddrOp_Word64 | ReadOffAddrOp_Char | ReadOffAddrOp_WideChar @@ -516,12 +528,12 @@ | ReadOffAddrOp_Double | ReadOffAddrOp_StablePtr | ReadOffAddrOp_Int8 - | ReadOffAddrOp_Int16 - | ReadOffAddrOp_Int32 - | ReadOffAddrOp_Int64 | ReadOffAddrOp_Word8 + | ReadOffAddrOp_Int16 | ReadOffAddrOp_Word16 + | ReadOffAddrOp_Int32 | ReadOffAddrOp_Word32 + | ReadOffAddrOp_Int64 | ReadOffAddrOp_Word64 | WriteOffAddrOp_Char | WriteOffAddrOp_WideChar @@ -532,12 +544,12 @@ | WriteOffAddrOp_Double | WriteOffAddrOp_StablePtr | WriteOffAddrOp_Int8 - | WriteOffAddrOp_Int16 - | WriteOffAddrOp_Int32 - | WriteOffAddrOp_Int64 | WriteOffAddrOp_Word8 + | WriteOffAddrOp_Int16 | WriteOffAddrOp_Word16 + | WriteOffAddrOp_Int32 | WriteOffAddrOp_Word32 + | WriteOffAddrOp_Int64 | WriteOffAddrOp_Word64 | InterlockedExchange_Addr | InterlockedExchange_Word @@ -558,6 +570,7 @@ | NewMutVarOp | ReadMutVarOp | WriteMutVarOp + | AtomicSwapMutVarOp | AtomicModifyMutVar2Op | AtomicModifyMutVar_Op | CasMutVarOp 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 @@ -30,16 +30,16 @@ , ("popCnt32#","Count the number of set bits in the lower 32 bits of a word.") , ("popCnt64#","Count the number of set bits in a 64-bit word.") , ("popCnt#","Count the number of set bits in a word.") - , ("pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.") - , ("pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.") - , ("pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.") - , ("pdep64#","Deposit bits to a word at locations specified by a mask.") - , ("pdep#","Deposit bits to a word at locations specified by a mask.") - , ("pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.") - , ("pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.") - , ("pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.") - , ("pext64#","Extract bits from a word at locations specified by a mask.") - , ("pext#","Extract bits from a word at locations specified by a mask.") + , ("pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pdep64#","Deposit bits to a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pdep#","Deposit bits to a word at locations specified by a mask, aka\n [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n Software emulation:\n\n > pdep :: Word -> Word -> Word\n > pdep src mask = go 0 src mask\n > where\n > go :: Word -> Word -> Word -> Word\n > go result _ 0 = result\n > go result src mask = go newResult newSrc newMask\n > where\n > maskCtz = countTrailingZeros mask\n > newResult = if testBit src 0 then setBit result maskCtz else result\n > newSrc = src `shiftR` 1\n > newMask = clearBit mask maskCtz\n\n @since 0.5.2.0") + , ("pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pext64#","Extract bits from a word at locations specified by a mask.\n\n @since 0.5.2.0") + , ("pext#","Extract bits from a word at locations specified by a mask, aka\n [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n Software emulation:\n\n > pext :: Word -> Word -> Word\n > pext src mask = loop 0 0 0\n > where\n > loop i count result\n > | i >= finiteBitSize (0 :: Word)\n > = result\n > | testBit mask i\n > = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)\n > | otherwise\n > = loop (i + 1) count result\n\n @since 0.5.2.0") , ("clz8#","Count leading zeros in the lower 8 bits of a word.") , ("clz16#","Count leading zeros in the lower 16 bits of a word.") , ("clz32#","Count leading zeros in the lower 32 bits of a word.") @@ -65,6 +65,14 @@ , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.") , ("float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n Results are undefined if the truncation if truncation yields\n a value outside the range of 'Int#'.") , ("decodeFloat_Int#","Convert to integers.\n First 'Int#' in result is the mantissa; second is the exponent.") + , ("fmaddFloat#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".") + , ("fmsubFloat#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".") + , ("fnmaddFloat#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".") + , ("fnmsubFloat#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".") + , ("fmaddDouble#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".") + , ("fmsubDouble#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".") + , ("fnmaddDouble#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".") + , ("fnmsubDouble#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".") , ("newArray#","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.") , ("readArray#","Read from specified index of mutable array. Result is not yet evaluated.") , ("writeArray#","Write to specified index of mutable array.") @@ -81,12 +89,12 @@ , ("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 boxed 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 'getSizeofSmallMutableArray#'.") + , ("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#'.\n\n Assuming the non-profiling RTS, for the copying garbage collector\n (default) this primitive compiles to an O(1) operation in C--, modifying\n the array in-place. For the non-moving garbage collector, however, the\n time is proportional to the number of elements shrinked out. Backends\n bypassing C-- representation (such as JavaScript) might behave\n differently.\n\n @since 0.6.1") , ("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 shrink and resize operations on the\n same small mutable array.") - , ("getSizeofSmallMutableArray#","Return the number of elements in the array.") + , ("sizeofSmallMutableArray#","Return the number of elements in the array. __Deprecated__, it is\n unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@\n operations on the same small mutable array.") + , ("getSizeofSmallMutableArray#","Return the number of elements in the array, correctly accounting for\n the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.\n\n @since 0.6.1") , ("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.") , ("unsafeThawSmallArray#","Make an immutable array mutable, without copying.") @@ -106,13 +114,13 @@ , ("isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move during GC.") , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!") , ("mutableByteArrayContents#","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 '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.") + , ("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#'.\n\n Assuming the non-profiling RTS, this primitive compiles to an O(1)\n operation in C--, modifying the array in-place. Backends bypassing C--\n representation (such as JavaScript) might behave differently.\n\n @since 0.4.0.0") + , ("resizeMutableByteArray#","Resize mutable byte array to new specified size (in bytes), shrinking or growing it.\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.\n\n @since 0.4.0.0") , ("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 shrink and resize operations on the same mutable byte\n array.") - , ("getSizeofMutableByteArray#","Return the number of elements in the array.") - , ("indexCharArray#","Read a 8-bit character; offset in bytes.") + , ("sizeofMutableByteArray#","Return the size of the array in bytes. __Deprecated__, it is\n unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'\n operations on the same mutable byte\n array.") + , ("getSizeofMutableByteArray#","Return the number of elements in the array, correctly accounting for\n the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.\n\n @since 0.5.0.0") + , ("indexCharArray#","Read an 8-bit character; offset in bytes.") , ("indexWideCharArray#","Read a 32-bit character; offset in 4-byte words.") , ("indexIntArray#","Read a word-sized integer; offset in machine words.") , ("indexWordArray#","Read a word-sized unsigned integer; offset in machine words.") @@ -120,15 +128,15 @@ , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.") , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.") , ("indexStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.") - , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.") + , ("indexInt8Array#","Read an 8-bit signed integer; offset in bytes.") + , ("indexWord8Array#","Read an 8-bit unsigned integer; offset in bytes.") , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.") - , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.") - , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.") - , ("indexWord8Array#","Read a 8-bit unsigned integer; offset in bytes.") , ("indexWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.") + , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.") , ("indexWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.") + , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.") , ("indexWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.") - , ("indexWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.") + , ("indexWord8ArrayAsChar#","Read an 8-bit character; offset in bytes.") , ("indexWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.") , ("indexWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.") , ("indexWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.") @@ -137,12 +145,12 @@ , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.") , ("indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.") , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.") - , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.") - , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.") , ("indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.") + , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.") , ("indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.") + , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.") , ("indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.") - , ("readCharArray#","Read a 8-bit character; offset in bytes.") + , ("readCharArray#","Read an 8-bit character; offset in bytes.") , ("readWideCharArray#","Read a 32-bit character; offset in 4-byte words.") , ("readIntArray#","Read a word-sized integer; offset in machine words.") , ("readWordArray#","Read a word-sized unsigned integer; offset in machine words.") @@ -150,15 +158,15 @@ , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.") , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.") , ("readStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.") - , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.") + , ("readInt8Array#","Read an 8-bit signed integer; offset in bytes.") + , ("readWord8Array#","Read an 8-bit unsigned integer; offset in bytes.") , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.") - , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.") - , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.") - , ("readWord8Array#","Read a 8-bit unsigned integer; offset in bytes.") , ("readWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.") + , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.") , ("readWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.") + , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.") , ("readWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.") - , ("readWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.") + , ("readWord8ArrayAsChar#","Read an 8-bit character; offset in bytes.") , ("readWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.") , ("readWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.") , ("readWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.") @@ -167,12 +175,12 @@ , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.") , ("readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.") , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.") - , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.") - , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.") , ("readWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.") + , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.") , ("readWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.") + , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.") , ("readWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.") - , ("writeCharArray#","Write a 8-bit character; offset in bytes.") + , ("writeCharArray#","Write an 8-bit character; offset in bytes.") , ("writeWideCharArray#","Write a 32-bit character; offset in 4-byte words.") , ("writeIntArray#","Write a word-sized integer; offset in machine words.") , ("writeWordArray#","Write a word-sized unsigned integer; offset in machine words.") @@ -180,15 +188,15 @@ , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.") , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.") , ("writeStablePtrArray#","Write a 'StablePtr#' value; offset in machine words.") - , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.") + , ("writeInt8Array#","Write an 8-bit signed integer; offset in bytes.") + , ("writeWord8Array#","Write an 8-bit unsigned integer; offset in bytes.") , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.") - , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.") - , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.") - , ("writeWord8Array#","Write a 8-bit unsigned integer; offset in bytes.") , ("writeWord16Array#","Write a 16-bit unsigned integer; offset in 2-byte words.") + , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.") , ("writeWord32Array#","Write a 32-bit unsigned integer; offset in 4-byte words.") + , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.") , ("writeWord64Array#","Write a 64-bit unsigned integer; offset in 8-byte words.") - , ("writeWord8ArrayAsChar#","Write a 8-bit character; offset in bytes.") + , ("writeWord8ArrayAsChar#","Write an 8-bit character; offset in bytes.") , ("writeWord8ArrayAsWideChar#","Write a 32-bit character; offset in bytes.") , ("writeWord8ArrayAsInt#","Write a word-sized integer; offset in bytes.") , ("writeWord8ArrayAsWord#","Write a word-sized unsigned integer; offset in bytes.") @@ -197,18 +205,22 @@ , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.") , ("writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.") , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.") - , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.") - , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.") , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.") + , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.") , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.") + , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.") , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.") , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n @n@ bytes starting at offset @src1_ofs@ in the first\n 'ByteArray#' @src1@ to the range of @n@ bytes\n (i.e. same length) starting at offset @src2_ofs@ of the second\n 'ByteArray#' @src2@. Both arrays must fully contain the\n specified ranges, but this is not checked. Returns an 'Int#'\n less than, equal to, or greater than zero if the range is found,\n respectively, to be byte-wise lexicographically less than, to\n match, or be greater than the second range.") - , ("copyByteArray#","@'copyByteArray#' src src_ofs dst dst_ofs n@ copies the range\n starting at offset @src_ofs@ of length @n@ from the\n 'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain\n the specified ranges, but this is not checked. The two arrays must\n not be the same array in different states, but this is not checked\n either.") - , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n allowed to overlap, although this is only possible when the same array is provided\n as both the source and the destination.") + , ("copyByteArray#"," @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range\n starting at offset @src_ofs@ of length @len@ from the\n 'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain\n the specified ranges, but this is not checked. The two arrays must\n not be the same array in different states, but this is not checked\n either.\n ") + , ("copyMutableByteArray#"," @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the\n range starting at offset @src_ofs@ of length @len@ from the\n 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain the\n specified ranges, but this is not checked. The regions are\n allowed to overlap, although this is only possible when the same\n array is provided as both the source and the destination.\n ") + , ("copyMutableByteArrayNonOverlapping#"," @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@\n copies the range starting at offset @src_ofs@ of length @len@ from\n the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain the\n specified ranges, but this is not checked. The regions are /not/\n allowed to overlap, but this is also not checked.\n\n @since 0.11.0\n ") , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n The ByteArray\\# and the memory region at Addr\\# must fully contain the\n specified ranges, but this is not checked. The Addr\\# must not point into the\n ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n either.") , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n pinned), but this is not checked either.") , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n but this is not checked either.") + , ("copyAddrToAddr#"," @'copyAddrToAddr#' src dest len@ copies @len@ bytes\n from @src@ to @dest@. These two memory ranges are allowed to overlap.\n\n Analogous to the standard C function @memmove@, but with a different\n argument order.\n\n @since 0.11.0\n ") + , ("copyAddrToAddrNonOverlapping#"," @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes\n from @src@ to @dest@. As the name suggests, these two memory ranges\n /must not overlap/, although this pre-condition is not checked.\n\n Analogous to the standard C function @memcpy@, but with a different\n argument order.\n\n @since 0.11.0\n ") , ("setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n the 'MutableByteArray#' to the byte @c@.") + , ("setAddrRange#"," @'setAddrRange#' dest len c@ sets all of the bytes in\n @[dest, dest+len)@ to the value @c@.\n\n Analogous to the standard C function @memset@, but with a different\n argument order.\n\n @since 0.11.0\n ") , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("casIntArray#","Given an array, an offset in machine words, 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 matches the provided old value. Returns\n the value of the element before the operation. Implies a full memory\n barrier.") @@ -228,10 +240,54 @@ , ("remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n is divided by the 'Int#' arg.") , ("addr2Int#","Coerce directly from address to int.") , ("int2Addr#","Coerce directly from int to address.") - , ("indexCharOffAddr#","Reads 8-bit character; offset in bytes.") - , ("indexWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.") - , ("readCharOffAddr#","Reads 8-bit character; offset in bytes.") - , ("readWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.") + , ("indexCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n") + , ("indexWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexWordOffAddr#","Read a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexAddrOffAddr#","Read a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexFloatOffAddr#","Read a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexDoubleOffAddr#","Read a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexStablePtrOffAddr#","Read a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexInt8OffAddr#","Read an 8-bit signed integer; offset in bytes.\n\n") + , ("indexWord8OffAddr#","Read an 8-bit unsigned integer; offset in bytes.\n\n") + , ("indexInt16OffAddr#","Read a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexWord16OffAddr#","Read a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexInt32OffAddr#","Read a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("indexWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n") + , ("readWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readWordOffAddr#","Read a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readAddrOffAddr#","Read a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readFloatOffAddr#","Read a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readDoubleOffAddr#","Read a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readStablePtrOffAddr#","Read a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readInt8OffAddr#","Read an 8-bit signed integer; offset in bytes.\n\n") + , ("readWord8OffAddr#","Read an 8-bit unsigned integer; offset in bytes.\n\n") + , ("readInt16OffAddr#","Read a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readWord16OffAddr#","Read a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readInt32OffAddr#","Read a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("readWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeCharOffAddr#","Write an 8-bit character; offset in bytes.\n\n") + , ("writeWideCharOffAddr#","Write a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeIntOffAddr#","Write a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeWordOffAddr#","Write a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeAddrOffAddr#","Write a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeFloatOffAddr#","Write a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeDoubleOffAddr#","Write a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeStablePtrOffAddr#","Write a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeInt8OffAddr#","Write an 8-bit signed integer; offset in bytes.\n\n") + , ("writeWord8OffAddr#","Write an 8-bit unsigned integer; offset in bytes.\n\n") + , ("writeInt16OffAddr#","Write a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeWord16OffAddr#","Write a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeInt32OffAddr#","Write a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeWord32OffAddr#","Write a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeInt64OffAddr#","Write a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") + , ("writeWord64OffAddr#","Write a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.") , ("atomicExchangeAddrAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n with the Addr# given as second argument. Implies a read barrier.") , ("atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n with the given value. Returns the old value. Implies a read barrier.") , ("atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n This version always returns the old value read. This follows the normal\n protocol for CAS operations (and matches the underlying instruction on\n most architectures).\n\n Implies a full memory barrier.") @@ -252,7 +308,8 @@ , ("newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.") , ("readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.") , ("writeMutVar#","Write contents of 'MutVar#'.") - , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n contents and the result of applying the given function to the\n previous contents. Note that this isn't strictly\n speaking the correct type for this function; it should really be\n @'MutVar#' s a -> (a -> (a,b)) -> 'State#' s -> (# 'State#' s, a, (a, b) #)@,\n but we don't know about pairs here. ") + , ("atomicSwapMutVar#","Atomically exchange the value of a 'MutVar#'.") + , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n contents @x :: a@ and the result of applying the given function to the\n previous contents @f x :: c@.\n\n The @data@ type @c@ (not a @newtype@!) must be a record whose first field\n is of lifted type @a :: Type@ and is not unpacked. For example, product\n types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both\n monomorphic and strict in its first field, it's recommended to mark the\n latter @{-# NOUNPACK #-}@ explicitly.\n\n Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an\n old @x :: a@ with a pointer to a selector thunk @fst r@, where\n @fst@ is a selector for the first field of the record and @r@ is a\n function application thunk @r = f x@.\n\n @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an\n effort to reflect restrictions on @c@ faithfully, providing a\n well-typed high-level wrapper.") , ("atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n contents and the result of applying the given function to the\n previous contents. ") , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n the first value passed to this function and the value\n stored inside the 'MutVar#'. If the pointers are equal,\n replace the stored value with the second value passed to this\n function, otherwise do nothing.\n Returns the final value stored inside the 'MutVar#'.\n The 'Int#' indicates whether a swap took place,\n with @1#@ meaning that we didn't swap, and @0#@\n that we did.\n Implies a full memory barrier.\n Because the comparison is done on the level of pointers,\n all of the difficulties of using\n 'reallyUnsafePtrEquality#' correctly apply to\n 'casMutVar#' as well.\n ") , ("catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n thrown.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") @@ -324,13 +381,12 @@ , ("Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n type variable. It's used when you want to pass around proxy values\n for doing things like modelling type applications. A 'Proxy#'\n is not only unboxed, it also has a polymorphic kind, and has no\n runtime representation, being totally free. ") , ("proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n representation. ") , ("seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n otherwise equal to @b@. In other words, it evaluates the first\n argument @a@ to weak head normal form (WHNF). 'seq' is usually\n introduced to improve performance by avoiding unneeded laziness.\n\n A note on evaluation order: the expression @'seq' a b@ does\n /not/ guarantee that @a@ will be evaluated before @b@.\n The only guarantee given by 'seq' is that the both @a@\n and @b@ will be evaluated before 'seq' returns a value.\n In particular, this means that @b@ may be evaluated before\n @a@. If you need to guarantee a specific order of evaluation,\n you must use the function 'pseq' from the \"parallel\" package. ") - , ("unsafeCoerce#"," The function 'unsafeCoerce#' allows you to side-step the typechecker entirely. That\n is, it allows you to coerce any type into any other type. If you use this function,\n you had better get it right, otherwise segmentation faults await. It is generally\n used when you want to write a program that you know is well-typed, but where Haskell's\n type system is not expressive enough to prove that it is well typed.\n\n The following uses of 'unsafeCoerce#' are supposed to work (i.e. not lead to\n spurious compile-time or run-time crashes):\n\n * Casting any lifted type to 'Any'\n\n * Casting 'Any' back to the real type\n\n * Casting an unboxed type to another unboxed type of the same size.\n (Casting between floating-point and integral types does not work.\n See the \"GHC.Float\" module for functions to do work.)\n\n * Casting between two types that have the same runtime representation. One case is when\n the two types differ only in \"phantom\" type parameters, for example\n @'Ptr' 'Int'@ to @'Ptr' 'Float'@, or @['Int']@ to @['Float']@ when the list is\n known to be empty. Also, a @newtype@ of a type @T@ has the same representation\n at runtime as @T@.\n\n Other uses of 'unsafeCoerce#' are undefined. In particular, you should not use\n 'unsafeCoerce#' to cast a T to an algebraic data type D, unless T is also\n an algebraic data type. For example, do not cast @'Int'->'Int'@ to 'Bool', even if\n you later cast that 'Bool' back to @'Int'->'Int'@ before applying it. The reasons\n have to do with GHC's internal representation details (for the cognoscenti, data values\n can be entered but function closures cannot). If you want a safe type to cast things\n to, use 'Any', which is not an algebraic data type.\n\n ") , ("traceEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the binary object passed as the first argument with\n the given length passed as the second argument. The event will be\n emitted to the @.eventlog@ file. ") , ("traceMarker#"," Emits a marker event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ") , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n with a function in \"GHC.Stack.CloneStack\". Please check the\n documentation in that module for more detailed explanations. ") - , ("coerce"," The function 'coerce' allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n When used in conversions involving a newtype wrapper,\n make sure the newtype constructor is in scope.\n\n This function is representation-polymorphic, but the\n 'RuntimeRep' type argument is marked as 'Inferred', meaning\n that it is not available for visible type application. This means\n the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n\n === __Examples__\n\n >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)\n >>> newtype Age = Age Int deriving (Eq, Ord, Show)\n >>> coerce (Age 42) :: TTL\n TTL 42\n >>> coerce (+ (1 :: Int)) (Age 42) :: TTL\n TTL 43\n >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]\n [TTL 43,TTL 25]\n\n ") + , ("coerce"," The function 'coerce' allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is representation-polymorphic, but the\n 'RuntimeRep' type argument is marked as 'Inferred', meaning\n that it is not available for visible type application. This means\n the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n ") , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ") 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 @@ -38,12 +38,12 @@ primOpHasSideEffects ReadByteArrayOp_Double = True primOpHasSideEffects ReadByteArrayOp_StablePtr = True primOpHasSideEffects ReadByteArrayOp_Int8 = True -primOpHasSideEffects ReadByteArrayOp_Int16 = True -primOpHasSideEffects ReadByteArrayOp_Int32 = True -primOpHasSideEffects ReadByteArrayOp_Int64 = True primOpHasSideEffects ReadByteArrayOp_Word8 = True +primOpHasSideEffects ReadByteArrayOp_Int16 = True primOpHasSideEffects ReadByteArrayOp_Word16 = True +primOpHasSideEffects ReadByteArrayOp_Int32 = True primOpHasSideEffects ReadByteArrayOp_Word32 = True +primOpHasSideEffects ReadByteArrayOp_Int64 = True primOpHasSideEffects ReadByteArrayOp_Word64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True @@ -54,10 +54,10 @@ primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True -primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True -primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True +primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True +primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True primOpHasSideEffects WriteByteArrayOp_Char = True primOpHasSideEffects WriteByteArrayOp_WideChar = True @@ -68,12 +68,12 @@ primOpHasSideEffects WriteByteArrayOp_Double = True primOpHasSideEffects WriteByteArrayOp_StablePtr = True primOpHasSideEffects WriteByteArrayOp_Int8 = True -primOpHasSideEffects WriteByteArrayOp_Int16 = True -primOpHasSideEffects WriteByteArrayOp_Int32 = True -primOpHasSideEffects WriteByteArrayOp_Int64 = True primOpHasSideEffects WriteByteArrayOp_Word8 = True +primOpHasSideEffects WriteByteArrayOp_Int16 = True primOpHasSideEffects WriteByteArrayOp_Word16 = True +primOpHasSideEffects WriteByteArrayOp_Int32 = True primOpHasSideEffects WriteByteArrayOp_Word32 = True +primOpHasSideEffects WriteByteArrayOp_Int64 = True primOpHasSideEffects WriteByteArrayOp_Word64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True @@ -84,17 +84,21 @@ primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True -primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True -primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True +primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True +primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True primOpHasSideEffects CopyByteArrayOp = True primOpHasSideEffects CopyMutableByteArrayOp = True +primOpHasSideEffects CopyMutableByteArrayNonOverlappingOp = True primOpHasSideEffects CopyByteArrayToAddrOp = True primOpHasSideEffects CopyMutableByteArrayToAddrOp = True primOpHasSideEffects CopyAddrToByteArrayOp = True +primOpHasSideEffects CopyAddrToAddrOp = True +primOpHasSideEffects CopyAddrToAddrNonOverlappingOp = True primOpHasSideEffects SetByteArrayOp = True +primOpHasSideEffects SetAddrRangeOp = True primOpHasSideEffects AtomicReadByteArrayOp_Int = True primOpHasSideEffects AtomicWriteByteArrayOp_Int = True primOpHasSideEffects CasByteArrayOp_Int = True @@ -117,12 +121,12 @@ primOpHasSideEffects ReadOffAddrOp_Double = True primOpHasSideEffects ReadOffAddrOp_StablePtr = True primOpHasSideEffects ReadOffAddrOp_Int8 = True -primOpHasSideEffects ReadOffAddrOp_Int16 = True -primOpHasSideEffects ReadOffAddrOp_Int32 = True -primOpHasSideEffects ReadOffAddrOp_Int64 = True primOpHasSideEffects ReadOffAddrOp_Word8 = True +primOpHasSideEffects ReadOffAddrOp_Int16 = True primOpHasSideEffects ReadOffAddrOp_Word16 = True +primOpHasSideEffects ReadOffAddrOp_Int32 = True primOpHasSideEffects ReadOffAddrOp_Word32 = True +primOpHasSideEffects ReadOffAddrOp_Int64 = True primOpHasSideEffects ReadOffAddrOp_Word64 = True primOpHasSideEffects WriteOffAddrOp_Char = True primOpHasSideEffects WriteOffAddrOp_WideChar = True @@ -133,12 +137,12 @@ primOpHasSideEffects WriteOffAddrOp_Double = True primOpHasSideEffects WriteOffAddrOp_StablePtr = True primOpHasSideEffects WriteOffAddrOp_Int8 = True -primOpHasSideEffects WriteOffAddrOp_Int16 = True -primOpHasSideEffects WriteOffAddrOp_Int32 = True -primOpHasSideEffects WriteOffAddrOp_Int64 = True primOpHasSideEffects WriteOffAddrOp_Word8 = True +primOpHasSideEffects WriteOffAddrOp_Int16 = True primOpHasSideEffects WriteOffAddrOp_Word16 = True +primOpHasSideEffects WriteOffAddrOp_Int32 = True primOpHasSideEffects WriteOffAddrOp_Word32 = True +primOpHasSideEffects WriteOffAddrOp_Int64 = True primOpHasSideEffects WriteOffAddrOp_Word64 = True primOpHasSideEffects InterlockedExchange_Addr = True primOpHasSideEffects InterlockedExchange_Word = True @@ -159,6 +163,7 @@ primOpHasSideEffects NewMutVarOp = True primOpHasSideEffects ReadMutVarOp = True primOpHasSideEffects WriteMutVarOp = True +primOpHasSideEffects AtomicSwapMutVarOp = True primOpHasSideEffects AtomicModifyMutVar2Op = True primOpHasSideEffects AtomicModifyMutVar_Op = True primOpHasSideEffects CasMutVarOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-list.hs-incl @@ -324,6 +324,14 @@ , FloatPowerOp , FloatToDoubleOp , FloatDecode_IntOp + , FloatFMAdd + , FloatFMSub + , FloatFNMAdd + , FloatFNMSub + , DoubleFMAdd + , DoubleFMSub + , DoubleFNMAdd + , DoubleFNMSub , NewArrayOp , ReadArrayOp , WriteArrayOp @@ -378,12 +386,12 @@ , IndexByteArrayOp_Double , IndexByteArrayOp_StablePtr , IndexByteArrayOp_Int8 - , IndexByteArrayOp_Int16 - , IndexByteArrayOp_Int32 - , IndexByteArrayOp_Int64 , IndexByteArrayOp_Word8 + , IndexByteArrayOp_Int16 , IndexByteArrayOp_Word16 + , IndexByteArrayOp_Int32 , IndexByteArrayOp_Word32 + , IndexByteArrayOp_Int64 , IndexByteArrayOp_Word64 , IndexByteArrayOp_Word8AsChar , IndexByteArrayOp_Word8AsWideChar @@ -394,10 +402,10 @@ , IndexByteArrayOp_Word8AsDouble , IndexByteArrayOp_Word8AsStablePtr , IndexByteArrayOp_Word8AsInt16 - , IndexByteArrayOp_Word8AsInt32 - , IndexByteArrayOp_Word8AsInt64 , IndexByteArrayOp_Word8AsWord16 + , IndexByteArrayOp_Word8AsInt32 , IndexByteArrayOp_Word8AsWord32 + , IndexByteArrayOp_Word8AsInt64 , IndexByteArrayOp_Word8AsWord64 , ReadByteArrayOp_Char , ReadByteArrayOp_WideChar @@ -408,12 +416,12 @@ , ReadByteArrayOp_Double , ReadByteArrayOp_StablePtr , ReadByteArrayOp_Int8 - , ReadByteArrayOp_Int16 - , ReadByteArrayOp_Int32 - , ReadByteArrayOp_Int64 , ReadByteArrayOp_Word8 + , ReadByteArrayOp_Int16 , ReadByteArrayOp_Word16 + , ReadByteArrayOp_Int32 , ReadByteArrayOp_Word32 + , ReadByteArrayOp_Int64 , ReadByteArrayOp_Word64 , ReadByteArrayOp_Word8AsChar , ReadByteArrayOp_Word8AsWideChar @@ -424,10 +432,10 @@ , ReadByteArrayOp_Word8AsDouble , ReadByteArrayOp_Word8AsStablePtr , ReadByteArrayOp_Word8AsInt16 - , ReadByteArrayOp_Word8AsInt32 - , ReadByteArrayOp_Word8AsInt64 , ReadByteArrayOp_Word8AsWord16 + , ReadByteArrayOp_Word8AsInt32 , ReadByteArrayOp_Word8AsWord32 + , ReadByteArrayOp_Word8AsInt64 , ReadByteArrayOp_Word8AsWord64 , WriteByteArrayOp_Char , WriteByteArrayOp_WideChar @@ -438,12 +446,12 @@ , WriteByteArrayOp_Double , WriteByteArrayOp_StablePtr , WriteByteArrayOp_Int8 - , WriteByteArrayOp_Int16 - , WriteByteArrayOp_Int32 - , WriteByteArrayOp_Int64 , WriteByteArrayOp_Word8 + , WriteByteArrayOp_Int16 , WriteByteArrayOp_Word16 + , WriteByteArrayOp_Int32 , WriteByteArrayOp_Word32 + , WriteByteArrayOp_Int64 , WriteByteArrayOp_Word64 , WriteByteArrayOp_Word8AsChar , WriteByteArrayOp_Word8AsWideChar @@ -454,18 +462,22 @@ , WriteByteArrayOp_Word8AsDouble , WriteByteArrayOp_Word8AsStablePtr , WriteByteArrayOp_Word8AsInt16 - , WriteByteArrayOp_Word8AsInt32 - , WriteByteArrayOp_Word8AsInt64 , WriteByteArrayOp_Word8AsWord16 + , WriteByteArrayOp_Word8AsInt32 , WriteByteArrayOp_Word8AsWord32 + , WriteByteArrayOp_Word8AsInt64 , WriteByteArrayOp_Word8AsWord64 , CompareByteArraysOp , CopyByteArrayOp , CopyMutableByteArrayOp + , CopyMutableByteArrayNonOverlappingOp , CopyByteArrayToAddrOp , CopyMutableByteArrayToAddrOp , CopyAddrToByteArrayOp + , CopyAddrToAddrOp + , CopyAddrToAddrNonOverlappingOp , SetByteArrayOp + , SetAddrRangeOp , AtomicReadByteArrayOp_Int , AtomicWriteByteArrayOp_Int , CasByteArrayOp_Int @@ -499,12 +511,12 @@ , IndexOffAddrOp_Double , IndexOffAddrOp_StablePtr , IndexOffAddrOp_Int8 - , IndexOffAddrOp_Int16 - , IndexOffAddrOp_Int32 - , IndexOffAddrOp_Int64 , IndexOffAddrOp_Word8 + , IndexOffAddrOp_Int16 , IndexOffAddrOp_Word16 + , IndexOffAddrOp_Int32 , IndexOffAddrOp_Word32 + , IndexOffAddrOp_Int64 , IndexOffAddrOp_Word64 , ReadOffAddrOp_Char , ReadOffAddrOp_WideChar @@ -515,12 +527,12 @@ , ReadOffAddrOp_Double , ReadOffAddrOp_StablePtr , ReadOffAddrOp_Int8 - , ReadOffAddrOp_Int16 - , ReadOffAddrOp_Int32 - , ReadOffAddrOp_Int64 , ReadOffAddrOp_Word8 + , ReadOffAddrOp_Int16 , ReadOffAddrOp_Word16 + , ReadOffAddrOp_Int32 , ReadOffAddrOp_Word32 + , ReadOffAddrOp_Int64 , ReadOffAddrOp_Word64 , WriteOffAddrOp_Char , WriteOffAddrOp_WideChar @@ -531,12 +543,12 @@ , WriteOffAddrOp_Double , WriteOffAddrOp_StablePtr , WriteOffAddrOp_Int8 - , WriteOffAddrOp_Int16 - , WriteOffAddrOp_Int32 - , WriteOffAddrOp_Int64 , WriteOffAddrOp_Word8 + , WriteOffAddrOp_Int16 , WriteOffAddrOp_Word16 + , WriteOffAddrOp_Int32 , WriteOffAddrOp_Word32 + , WriteOffAddrOp_Int64 , WriteOffAddrOp_Word64 , InterlockedExchange_Addr , InterlockedExchange_Word @@ -557,6 +569,7 @@ , NewMutVarOp , ReadMutVarOp , WriteMutVarOp + , AtomicSwapMutVarOp , AtomicModifyMutVar2Op , AtomicModifyMutVar_Op , CasMutVarOp diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -324,6 +324,14 @@ primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) +primOpInfo FloatFMAdd = mkGenPrimOp (fsLit "fmaddFloat#") [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy) +primOpInfo FloatFMSub = mkGenPrimOp (fsLit "fmsubFloat#") [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy) +primOpInfo FloatFNMAdd = mkGenPrimOp (fsLit "fnmaddFloat#") [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy) +primOpInfo FloatFNMSub = mkGenPrimOp (fsLit "fnmsubFloat#") [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy) +primOpInfo DoubleFMAdd = mkGenPrimOp (fsLit "fmaddDouble#") [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy) +primOpInfo DoubleFMSub = mkGenPrimOp (fsLit "fmsubDouble#") [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy) +primOpInfo DoubleFNMAdd = mkGenPrimOp (fsLit "fnmaddDouble#") [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy) +primOpInfo DoubleFNMSub = mkGenPrimOp (fsLit "fnmsubDouble#") [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy])) primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) @@ -378,12 +386,12 @@ primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#") [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (int8PrimTy) -primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) -primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) -primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (word8PrimTy) +primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) +primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy) +primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) @@ -394,10 +402,10 @@ primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#") [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) -primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) -primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) +primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy) +primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) @@ -408,12 +416,12 @@ primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) -primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) -primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) -primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) +primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) +primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) +primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) @@ -424,10 +432,10 @@ primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) -primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) -primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) +primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) +primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) @@ -438,12 +446,12 @@ primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) @@ -454,18 +462,22 @@ primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableByteArrayNonOverlappingOp = mkGenPrimOp (fsLit "copyMutableByteArrayNonOverlapping#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#") [deltaTyVarSpec] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyAddrToAddrOp = mkGenPrimOp (fsLit "copyAddrToAddr#") [] [addrPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo CopyAddrToAddrNonOverlappingOp = mkGenPrimOp (fsLit "copyAddrToAddrNonOverlapping#") [] [addrPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SetAddrRangeOp = mkGenPrimOp (fsLit "setAddrRange#") [] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) @@ -499,12 +511,12 @@ primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#") [] [addrPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#") [alphaTyVarSpec] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (int8PrimTy) -primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (int16PrimTy) -primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (int32PrimTy) -primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (word8PrimTy) +primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (word16PrimTy) +primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (int32PrimTy) primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (word32PrimTy) +primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) @@ -515,12 +527,12 @@ primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#") [deltaTyVarSpec, alphaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) -primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) -primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) -primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) +primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) +primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) +primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) @@ -531,12 +543,12 @@ primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#") [alphaTyVarSpec, deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#") [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) @@ -557,6 +569,7 @@ primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy levPolyAlphaTy])) primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo AtomicSwapMutVarOp = mkGenPrimOp (fsLit "atomicSwapMutVar#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVarSpec, alphaTyVarSpec, gammaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy])) primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) @@ -611,7 +624,7 @@ primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [levity2TyVarInf, levPolyBetaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, levPolyAlphaTy])) primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) -primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy levPolyAlphaTy])) primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStablePtrPrimTy levPolyAlphaTy] (intPrimTy) @@ -634,7 +647,7 @@ primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy) +primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy, (mkVisFunTyMany (mkStatePrimTy deltaTy) (openBetaTy))] (openBetaTy) primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVarSpec] [alphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVarSpec] [intPrimTy] (alphaTy) primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy])) 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 @@ -1,3 +1,5 @@ +primOpStrictness AtomicModifyMutVar2Op = \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv +primOpStrictness AtomicModifyMutVar_Op = \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv primOpStrictness CatchOp = \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd] topDiv @@ -9,7 +11,7 @@ primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv +primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv primOpStrictness Control0Op = \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv primOpStrictness AtomicallyOp = \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv primOpStrictness RetryOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl @@ -1,1315 +1,1328 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1311 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 0 -primOpTag CharGeOp = 1 -primOpTag CharEqOp = 2 -primOpTag CharNeOp = 3 -primOpTag CharLtOp = 4 -primOpTag CharLeOp = 5 -primOpTag OrdOp = 6 -primOpTag Int8ToIntOp = 7 -primOpTag IntToInt8Op = 8 -primOpTag Int8NegOp = 9 -primOpTag Int8AddOp = 10 -primOpTag Int8SubOp = 11 -primOpTag Int8MulOp = 12 -primOpTag Int8QuotOp = 13 -primOpTag Int8RemOp = 14 -primOpTag Int8QuotRemOp = 15 -primOpTag Int8SllOp = 16 -primOpTag Int8SraOp = 17 -primOpTag Int8SrlOp = 18 -primOpTag Int8ToWord8Op = 19 -primOpTag Int8EqOp = 20 -primOpTag Int8GeOp = 21 -primOpTag Int8GtOp = 22 -primOpTag Int8LeOp = 23 -primOpTag Int8LtOp = 24 -primOpTag Int8NeOp = 25 -primOpTag Word8ToWordOp = 26 -primOpTag WordToWord8Op = 27 -primOpTag Word8AddOp = 28 -primOpTag Word8SubOp = 29 -primOpTag Word8MulOp = 30 -primOpTag Word8QuotOp = 31 -primOpTag Word8RemOp = 32 -primOpTag Word8QuotRemOp = 33 -primOpTag Word8AndOp = 34 -primOpTag Word8OrOp = 35 -primOpTag Word8XorOp = 36 -primOpTag Word8NotOp = 37 -primOpTag Word8SllOp = 38 -primOpTag Word8SrlOp = 39 -primOpTag Word8ToInt8Op = 40 -primOpTag Word8EqOp = 41 -primOpTag Word8GeOp = 42 -primOpTag Word8GtOp = 43 -primOpTag Word8LeOp = 44 -primOpTag Word8LtOp = 45 -primOpTag Word8NeOp = 46 -primOpTag Int16ToIntOp = 47 -primOpTag IntToInt16Op = 48 -primOpTag Int16NegOp = 49 -primOpTag Int16AddOp = 50 -primOpTag Int16SubOp = 51 -primOpTag Int16MulOp = 52 -primOpTag Int16QuotOp = 53 -primOpTag Int16RemOp = 54 -primOpTag Int16QuotRemOp = 55 -primOpTag Int16SllOp = 56 -primOpTag Int16SraOp = 57 -primOpTag Int16SrlOp = 58 -primOpTag Int16ToWord16Op = 59 -primOpTag Int16EqOp = 60 -primOpTag Int16GeOp = 61 -primOpTag Int16GtOp = 62 -primOpTag Int16LeOp = 63 -primOpTag Int16LtOp = 64 -primOpTag Int16NeOp = 65 -primOpTag Word16ToWordOp = 66 -primOpTag WordToWord16Op = 67 -primOpTag Word16AddOp = 68 -primOpTag Word16SubOp = 69 -primOpTag Word16MulOp = 70 -primOpTag Word16QuotOp = 71 -primOpTag Word16RemOp = 72 -primOpTag Word16QuotRemOp = 73 -primOpTag Word16AndOp = 74 -primOpTag Word16OrOp = 75 -primOpTag Word16XorOp = 76 -primOpTag Word16NotOp = 77 -primOpTag Word16SllOp = 78 -primOpTag Word16SrlOp = 79 -primOpTag Word16ToInt16Op = 80 -primOpTag Word16EqOp = 81 -primOpTag Word16GeOp = 82 -primOpTag Word16GtOp = 83 -primOpTag Word16LeOp = 84 -primOpTag Word16LtOp = 85 -primOpTag Word16NeOp = 86 -primOpTag Int32ToIntOp = 87 -primOpTag IntToInt32Op = 88 -primOpTag Int32NegOp = 89 -primOpTag Int32AddOp = 90 -primOpTag Int32SubOp = 91 -primOpTag Int32MulOp = 92 -primOpTag Int32QuotOp = 93 -primOpTag Int32RemOp = 94 -primOpTag Int32QuotRemOp = 95 -primOpTag Int32SllOp = 96 -primOpTag Int32SraOp = 97 -primOpTag Int32SrlOp = 98 -primOpTag Int32ToWord32Op = 99 -primOpTag Int32EqOp = 100 -primOpTag Int32GeOp = 101 -primOpTag Int32GtOp = 102 -primOpTag Int32LeOp = 103 -primOpTag Int32LtOp = 104 -primOpTag Int32NeOp = 105 -primOpTag Word32ToWordOp = 106 -primOpTag WordToWord32Op = 107 -primOpTag Word32AddOp = 108 -primOpTag Word32SubOp = 109 -primOpTag Word32MulOp = 110 -primOpTag Word32QuotOp = 111 -primOpTag Word32RemOp = 112 -primOpTag Word32QuotRemOp = 113 -primOpTag Word32AndOp = 114 -primOpTag Word32OrOp = 115 -primOpTag Word32XorOp = 116 -primOpTag Word32NotOp = 117 -primOpTag Word32SllOp = 118 -primOpTag Word32SrlOp = 119 -primOpTag Word32ToInt32Op = 120 -primOpTag Word32EqOp = 121 -primOpTag Word32GeOp = 122 -primOpTag Word32GtOp = 123 -primOpTag Word32LeOp = 124 -primOpTag Word32LtOp = 125 -primOpTag Word32NeOp = 126 -primOpTag Int64ToIntOp = 127 -primOpTag IntToInt64Op = 128 -primOpTag Int64NegOp = 129 -primOpTag Int64AddOp = 130 -primOpTag Int64SubOp = 131 -primOpTag Int64MulOp = 132 -primOpTag Int64QuotOp = 133 -primOpTag Int64RemOp = 134 -primOpTag Int64SllOp = 135 -primOpTag Int64SraOp = 136 -primOpTag Int64SrlOp = 137 -primOpTag Int64ToWord64Op = 138 -primOpTag Int64EqOp = 139 -primOpTag Int64GeOp = 140 -primOpTag Int64GtOp = 141 -primOpTag Int64LeOp = 142 -primOpTag Int64LtOp = 143 -primOpTag Int64NeOp = 144 -primOpTag Word64ToWordOp = 145 -primOpTag WordToWord64Op = 146 -primOpTag Word64AddOp = 147 -primOpTag Word64SubOp = 148 -primOpTag Word64MulOp = 149 -primOpTag Word64QuotOp = 150 -primOpTag Word64RemOp = 151 -primOpTag Word64AndOp = 152 -primOpTag Word64OrOp = 153 -primOpTag Word64XorOp = 154 -primOpTag Word64NotOp = 155 -primOpTag Word64SllOp = 156 -primOpTag Word64SrlOp = 157 -primOpTag Word64ToInt64Op = 158 -primOpTag Word64EqOp = 159 -primOpTag Word64GeOp = 160 -primOpTag Word64GtOp = 161 -primOpTag Word64LeOp = 162 -primOpTag Word64LtOp = 163 -primOpTag Word64NeOp = 164 -primOpTag IntAddOp = 165 -primOpTag IntSubOp = 166 -primOpTag IntMulOp = 167 -primOpTag IntMul2Op = 168 -primOpTag IntMulMayOfloOp = 169 -primOpTag IntQuotOp = 170 -primOpTag IntRemOp = 171 -primOpTag IntQuotRemOp = 172 -primOpTag IntAndOp = 173 -primOpTag IntOrOp = 174 -primOpTag IntXorOp = 175 -primOpTag IntNotOp = 176 -primOpTag IntNegOp = 177 -primOpTag IntAddCOp = 178 -primOpTag IntSubCOp = 179 -primOpTag IntGtOp = 180 -primOpTag IntGeOp = 181 -primOpTag IntEqOp = 182 -primOpTag IntNeOp = 183 -primOpTag IntLtOp = 184 -primOpTag IntLeOp = 185 -primOpTag ChrOp = 186 -primOpTag IntToWordOp = 187 -primOpTag IntToFloatOp = 188 -primOpTag IntToDoubleOp = 189 -primOpTag WordToFloatOp = 190 -primOpTag WordToDoubleOp = 191 -primOpTag IntSllOp = 192 -primOpTag IntSraOp = 193 -primOpTag IntSrlOp = 194 -primOpTag WordAddOp = 195 -primOpTag WordAddCOp = 196 -primOpTag WordSubCOp = 197 -primOpTag WordAdd2Op = 198 -primOpTag WordSubOp = 199 -primOpTag WordMulOp = 200 -primOpTag WordMul2Op = 201 -primOpTag WordQuotOp = 202 -primOpTag WordRemOp = 203 -primOpTag WordQuotRemOp = 204 -primOpTag WordQuotRem2Op = 205 -primOpTag WordAndOp = 206 -primOpTag WordOrOp = 207 -primOpTag WordXorOp = 208 -primOpTag WordNotOp = 209 -primOpTag WordSllOp = 210 -primOpTag WordSrlOp = 211 -primOpTag WordToIntOp = 212 -primOpTag WordGtOp = 213 -primOpTag WordGeOp = 214 -primOpTag WordEqOp = 215 -primOpTag WordNeOp = 216 -primOpTag WordLtOp = 217 -primOpTag WordLeOp = 218 -primOpTag PopCnt8Op = 219 -primOpTag PopCnt16Op = 220 -primOpTag PopCnt32Op = 221 -primOpTag PopCnt64Op = 222 -primOpTag PopCntOp = 223 -primOpTag Pdep8Op = 224 -primOpTag Pdep16Op = 225 -primOpTag Pdep32Op = 226 -primOpTag Pdep64Op = 227 -primOpTag PdepOp = 228 -primOpTag Pext8Op = 229 -primOpTag Pext16Op = 230 -primOpTag Pext32Op = 231 -primOpTag Pext64Op = 232 -primOpTag PextOp = 233 -primOpTag Clz8Op = 234 -primOpTag Clz16Op = 235 -primOpTag Clz32Op = 236 -primOpTag Clz64Op = 237 -primOpTag ClzOp = 238 -primOpTag Ctz8Op = 239 -primOpTag Ctz16Op = 240 -primOpTag Ctz32Op = 241 -primOpTag Ctz64Op = 242 -primOpTag CtzOp = 243 -primOpTag BSwap16Op = 244 -primOpTag BSwap32Op = 245 -primOpTag BSwap64Op = 246 -primOpTag BSwapOp = 247 -primOpTag BRev8Op = 248 -primOpTag BRev16Op = 249 -primOpTag BRev32Op = 250 -primOpTag BRev64Op = 251 -primOpTag BRevOp = 252 -primOpTag Narrow8IntOp = 253 -primOpTag Narrow16IntOp = 254 -primOpTag Narrow32IntOp = 255 -primOpTag Narrow8WordOp = 256 -primOpTag Narrow16WordOp = 257 -primOpTag Narrow32WordOp = 258 -primOpTag DoubleGtOp = 259 -primOpTag DoubleGeOp = 260 -primOpTag DoubleEqOp = 261 -primOpTag DoubleNeOp = 262 -primOpTag DoubleLtOp = 263 -primOpTag DoubleLeOp = 264 -primOpTag DoubleAddOp = 265 -primOpTag DoubleSubOp = 266 -primOpTag DoubleMulOp = 267 -primOpTag DoubleDivOp = 268 -primOpTag DoubleNegOp = 269 -primOpTag DoubleFabsOp = 270 -primOpTag DoubleToIntOp = 271 -primOpTag DoubleToFloatOp = 272 -primOpTag DoubleExpOp = 273 -primOpTag DoubleExpM1Op = 274 -primOpTag DoubleLogOp = 275 -primOpTag DoubleLog1POp = 276 -primOpTag DoubleSqrtOp = 277 -primOpTag DoubleSinOp = 278 -primOpTag DoubleCosOp = 279 -primOpTag DoubleTanOp = 280 -primOpTag DoubleAsinOp = 281 -primOpTag DoubleAcosOp = 282 -primOpTag DoubleAtanOp = 283 -primOpTag DoubleSinhOp = 284 -primOpTag DoubleCoshOp = 285 -primOpTag DoubleTanhOp = 286 -primOpTag DoubleAsinhOp = 287 -primOpTag DoubleAcoshOp = 288 -primOpTag DoubleAtanhOp = 289 -primOpTag DoublePowerOp = 290 -primOpTag DoubleDecode_2IntOp = 291 -primOpTag DoubleDecode_Int64Op = 292 -primOpTag FloatGtOp = 293 -primOpTag FloatGeOp = 294 -primOpTag FloatEqOp = 295 -primOpTag FloatNeOp = 296 -primOpTag FloatLtOp = 297 -primOpTag FloatLeOp = 298 -primOpTag FloatAddOp = 299 -primOpTag FloatSubOp = 300 -primOpTag FloatMulOp = 301 -primOpTag FloatDivOp = 302 -primOpTag FloatNegOp = 303 -primOpTag FloatFabsOp = 304 -primOpTag FloatToIntOp = 305 -primOpTag FloatExpOp = 306 -primOpTag FloatExpM1Op = 307 -primOpTag FloatLogOp = 308 -primOpTag FloatLog1POp = 309 -primOpTag FloatSqrtOp = 310 -primOpTag FloatSinOp = 311 -primOpTag FloatCosOp = 312 -primOpTag FloatTanOp = 313 -primOpTag FloatAsinOp = 314 -primOpTag FloatAcosOp = 315 -primOpTag FloatAtanOp = 316 -primOpTag FloatSinhOp = 317 -primOpTag FloatCoshOp = 318 -primOpTag FloatTanhOp = 319 -primOpTag FloatAsinhOp = 320 -primOpTag FloatAcoshOp = 321 -primOpTag FloatAtanhOp = 322 -primOpTag FloatPowerOp = 323 -primOpTag FloatToDoubleOp = 324 -primOpTag FloatDecode_IntOp = 325 -primOpTag NewArrayOp = 326 -primOpTag ReadArrayOp = 327 -primOpTag WriteArrayOp = 328 -primOpTag SizeofArrayOp = 329 -primOpTag SizeofMutableArrayOp = 330 -primOpTag IndexArrayOp = 331 -primOpTag UnsafeFreezeArrayOp = 332 -primOpTag UnsafeThawArrayOp = 333 -primOpTag CopyArrayOp = 334 -primOpTag CopyMutableArrayOp = 335 -primOpTag CloneArrayOp = 336 -primOpTag CloneMutableArrayOp = 337 -primOpTag FreezeArrayOp = 338 -primOpTag ThawArrayOp = 339 -primOpTag CasArrayOp = 340 -primOpTag NewSmallArrayOp = 341 -primOpTag ShrinkSmallMutableArrayOp_Char = 342 -primOpTag ReadSmallArrayOp = 343 -primOpTag WriteSmallArrayOp = 344 -primOpTag SizeofSmallArrayOp = 345 -primOpTag SizeofSmallMutableArrayOp = 346 -primOpTag GetSizeofSmallMutableArrayOp = 347 -primOpTag IndexSmallArrayOp = 348 -primOpTag UnsafeFreezeSmallArrayOp = 349 -primOpTag UnsafeThawSmallArrayOp = 350 -primOpTag CopySmallArrayOp = 351 -primOpTag CopySmallMutableArrayOp = 352 -primOpTag CloneSmallArrayOp = 353 -primOpTag CloneSmallMutableArrayOp = 354 -primOpTag FreezeSmallArrayOp = 355 -primOpTag ThawSmallArrayOp = 356 -primOpTag CasSmallArrayOp = 357 -primOpTag NewByteArrayOp_Char = 358 -primOpTag NewPinnedByteArrayOp_Char = 359 -primOpTag NewAlignedPinnedByteArrayOp_Char = 360 -primOpTag MutableByteArrayIsPinnedOp = 361 -primOpTag ByteArrayIsPinnedOp = 362 -primOpTag ByteArrayContents_Char = 363 -primOpTag MutableByteArrayContents_Char = 364 -primOpTag ShrinkMutableByteArrayOp_Char = 365 -primOpTag ResizeMutableByteArrayOp_Char = 366 -primOpTag UnsafeFreezeByteArrayOp = 367 -primOpTag SizeofByteArrayOp = 368 -primOpTag SizeofMutableByteArrayOp = 369 -primOpTag GetSizeofMutableByteArrayOp = 370 -primOpTag IndexByteArrayOp_Char = 371 -primOpTag IndexByteArrayOp_WideChar = 372 -primOpTag IndexByteArrayOp_Int = 373 -primOpTag IndexByteArrayOp_Word = 374 -primOpTag IndexByteArrayOp_Addr = 375 -primOpTag IndexByteArrayOp_Float = 376 -primOpTag IndexByteArrayOp_Double = 377 -primOpTag IndexByteArrayOp_StablePtr = 378 -primOpTag IndexByteArrayOp_Int8 = 379 -primOpTag IndexByteArrayOp_Int16 = 380 -primOpTag IndexByteArrayOp_Int32 = 381 -primOpTag IndexByteArrayOp_Int64 = 382 -primOpTag IndexByteArrayOp_Word8 = 383 -primOpTag IndexByteArrayOp_Word16 = 384 -primOpTag IndexByteArrayOp_Word32 = 385 -primOpTag IndexByteArrayOp_Word64 = 386 -primOpTag IndexByteArrayOp_Word8AsChar = 387 -primOpTag IndexByteArrayOp_Word8AsWideChar = 388 -primOpTag IndexByteArrayOp_Word8AsInt = 389 -primOpTag IndexByteArrayOp_Word8AsWord = 390 -primOpTag IndexByteArrayOp_Word8AsAddr = 391 -primOpTag IndexByteArrayOp_Word8AsFloat = 392 -primOpTag IndexByteArrayOp_Word8AsDouble = 393 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 394 -primOpTag IndexByteArrayOp_Word8AsInt16 = 395 -primOpTag IndexByteArrayOp_Word8AsInt32 = 396 -primOpTag IndexByteArrayOp_Word8AsInt64 = 397 -primOpTag IndexByteArrayOp_Word8AsWord16 = 398 -primOpTag IndexByteArrayOp_Word8AsWord32 = 399 -primOpTag IndexByteArrayOp_Word8AsWord64 = 400 -primOpTag ReadByteArrayOp_Char = 401 -primOpTag ReadByteArrayOp_WideChar = 402 -primOpTag ReadByteArrayOp_Int = 403 -primOpTag ReadByteArrayOp_Word = 404 -primOpTag ReadByteArrayOp_Addr = 405 -primOpTag ReadByteArrayOp_Float = 406 -primOpTag ReadByteArrayOp_Double = 407 -primOpTag ReadByteArrayOp_StablePtr = 408 -primOpTag ReadByteArrayOp_Int8 = 409 -primOpTag ReadByteArrayOp_Int16 = 410 -primOpTag ReadByteArrayOp_Int32 = 411 -primOpTag ReadByteArrayOp_Int64 = 412 -primOpTag ReadByteArrayOp_Word8 = 413 -primOpTag ReadByteArrayOp_Word16 = 414 -primOpTag ReadByteArrayOp_Word32 = 415 -primOpTag ReadByteArrayOp_Word64 = 416 -primOpTag ReadByteArrayOp_Word8AsChar = 417 -primOpTag ReadByteArrayOp_Word8AsWideChar = 418 -primOpTag ReadByteArrayOp_Word8AsInt = 419 -primOpTag ReadByteArrayOp_Word8AsWord = 420 -primOpTag ReadByteArrayOp_Word8AsAddr = 421 -primOpTag ReadByteArrayOp_Word8AsFloat = 422 -primOpTag ReadByteArrayOp_Word8AsDouble = 423 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 424 -primOpTag ReadByteArrayOp_Word8AsInt16 = 425 -primOpTag ReadByteArrayOp_Word8AsInt32 = 426 -primOpTag ReadByteArrayOp_Word8AsInt64 = 427 -primOpTag ReadByteArrayOp_Word8AsWord16 = 428 -primOpTag ReadByteArrayOp_Word8AsWord32 = 429 -primOpTag ReadByteArrayOp_Word8AsWord64 = 430 -primOpTag WriteByteArrayOp_Char = 431 -primOpTag WriteByteArrayOp_WideChar = 432 -primOpTag WriteByteArrayOp_Int = 433 -primOpTag WriteByteArrayOp_Word = 434 -primOpTag WriteByteArrayOp_Addr = 435 -primOpTag WriteByteArrayOp_Float = 436 -primOpTag WriteByteArrayOp_Double = 437 -primOpTag WriteByteArrayOp_StablePtr = 438 -primOpTag WriteByteArrayOp_Int8 = 439 -primOpTag WriteByteArrayOp_Int16 = 440 -primOpTag WriteByteArrayOp_Int32 = 441 -primOpTag WriteByteArrayOp_Int64 = 442 -primOpTag WriteByteArrayOp_Word8 = 443 -primOpTag WriteByteArrayOp_Word16 = 444 -primOpTag WriteByteArrayOp_Word32 = 445 -primOpTag WriteByteArrayOp_Word64 = 446 -primOpTag WriteByteArrayOp_Word8AsChar = 447 -primOpTag WriteByteArrayOp_Word8AsWideChar = 448 -primOpTag WriteByteArrayOp_Word8AsInt = 449 -primOpTag WriteByteArrayOp_Word8AsWord = 450 -primOpTag WriteByteArrayOp_Word8AsAddr = 451 -primOpTag WriteByteArrayOp_Word8AsFloat = 452 -primOpTag WriteByteArrayOp_Word8AsDouble = 453 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 454 -primOpTag WriteByteArrayOp_Word8AsInt16 = 455 -primOpTag WriteByteArrayOp_Word8AsInt32 = 456 -primOpTag WriteByteArrayOp_Word8AsInt64 = 457 -primOpTag WriteByteArrayOp_Word8AsWord16 = 458 -primOpTag WriteByteArrayOp_Word8AsWord32 = 459 -primOpTag WriteByteArrayOp_Word8AsWord64 = 460 -primOpTag CompareByteArraysOp = 461 -primOpTag CopyByteArrayOp = 462 -primOpTag CopyMutableByteArrayOp = 463 -primOpTag CopyByteArrayToAddrOp = 464 -primOpTag CopyMutableByteArrayToAddrOp = 465 -primOpTag CopyAddrToByteArrayOp = 466 -primOpTag SetByteArrayOp = 467 -primOpTag AtomicReadByteArrayOp_Int = 468 -primOpTag AtomicWriteByteArrayOp_Int = 469 -primOpTag CasByteArrayOp_Int = 470 -primOpTag CasByteArrayOp_Int8 = 471 -primOpTag CasByteArrayOp_Int16 = 472 -primOpTag CasByteArrayOp_Int32 = 473 -primOpTag CasByteArrayOp_Int64 = 474 -primOpTag FetchAddByteArrayOp_Int = 475 -primOpTag FetchSubByteArrayOp_Int = 476 -primOpTag FetchAndByteArrayOp_Int = 477 -primOpTag FetchNandByteArrayOp_Int = 478 -primOpTag FetchOrByteArrayOp_Int = 479 -primOpTag FetchXorByteArrayOp_Int = 480 -primOpTag AddrAddOp = 481 -primOpTag AddrSubOp = 482 -primOpTag AddrRemOp = 483 -primOpTag AddrToIntOp = 484 -primOpTag IntToAddrOp = 485 -primOpTag AddrGtOp = 486 -primOpTag AddrGeOp = 487 -primOpTag AddrEqOp = 488 -primOpTag AddrNeOp = 489 -primOpTag AddrLtOp = 490 -primOpTag AddrLeOp = 491 -primOpTag IndexOffAddrOp_Char = 492 -primOpTag IndexOffAddrOp_WideChar = 493 -primOpTag IndexOffAddrOp_Int = 494 -primOpTag IndexOffAddrOp_Word = 495 -primOpTag IndexOffAddrOp_Addr = 496 -primOpTag IndexOffAddrOp_Float = 497 -primOpTag IndexOffAddrOp_Double = 498 -primOpTag IndexOffAddrOp_StablePtr = 499 -primOpTag IndexOffAddrOp_Int8 = 500 -primOpTag IndexOffAddrOp_Int16 = 501 -primOpTag IndexOffAddrOp_Int32 = 502 -primOpTag IndexOffAddrOp_Int64 = 503 -primOpTag IndexOffAddrOp_Word8 = 504 -primOpTag IndexOffAddrOp_Word16 = 505 -primOpTag IndexOffAddrOp_Word32 = 506 -primOpTag IndexOffAddrOp_Word64 = 507 -primOpTag ReadOffAddrOp_Char = 508 -primOpTag ReadOffAddrOp_WideChar = 509 -primOpTag ReadOffAddrOp_Int = 510 -primOpTag ReadOffAddrOp_Word = 511 -primOpTag ReadOffAddrOp_Addr = 512 -primOpTag ReadOffAddrOp_Float = 513 -primOpTag ReadOffAddrOp_Double = 514 -primOpTag ReadOffAddrOp_StablePtr = 515 -primOpTag ReadOffAddrOp_Int8 = 516 -primOpTag ReadOffAddrOp_Int16 = 517 -primOpTag ReadOffAddrOp_Int32 = 518 -primOpTag ReadOffAddrOp_Int64 = 519 -primOpTag ReadOffAddrOp_Word8 = 520 -primOpTag ReadOffAddrOp_Word16 = 521 -primOpTag ReadOffAddrOp_Word32 = 522 -primOpTag ReadOffAddrOp_Word64 = 523 -primOpTag WriteOffAddrOp_Char = 524 -primOpTag WriteOffAddrOp_WideChar = 525 -primOpTag WriteOffAddrOp_Int = 526 -primOpTag WriteOffAddrOp_Word = 527 -primOpTag WriteOffAddrOp_Addr = 528 -primOpTag WriteOffAddrOp_Float = 529 -primOpTag WriteOffAddrOp_Double = 530 -primOpTag WriteOffAddrOp_StablePtr = 531 -primOpTag WriteOffAddrOp_Int8 = 532 -primOpTag WriteOffAddrOp_Int16 = 533 -primOpTag WriteOffAddrOp_Int32 = 534 -primOpTag WriteOffAddrOp_Int64 = 535 -primOpTag WriteOffAddrOp_Word8 = 536 -primOpTag WriteOffAddrOp_Word16 = 537 -primOpTag WriteOffAddrOp_Word32 = 538 -primOpTag WriteOffAddrOp_Word64 = 539 -primOpTag InterlockedExchange_Addr = 540 -primOpTag InterlockedExchange_Word = 541 -primOpTag CasAddrOp_Addr = 542 -primOpTag CasAddrOp_Word = 543 -primOpTag CasAddrOp_Word8 = 544 -primOpTag CasAddrOp_Word16 = 545 -primOpTag CasAddrOp_Word32 = 546 -primOpTag CasAddrOp_Word64 = 547 -primOpTag FetchAddAddrOp_Word = 548 -primOpTag FetchSubAddrOp_Word = 549 -primOpTag FetchAndAddrOp_Word = 550 -primOpTag FetchNandAddrOp_Word = 551 -primOpTag FetchOrAddrOp_Word = 552 -primOpTag FetchXorAddrOp_Word = 553 -primOpTag AtomicReadAddrOp_Word = 554 -primOpTag AtomicWriteAddrOp_Word = 555 -primOpTag NewMutVarOp = 556 -primOpTag ReadMutVarOp = 557 -primOpTag WriteMutVarOp = 558 -primOpTag AtomicModifyMutVar2Op = 559 -primOpTag AtomicModifyMutVar_Op = 560 -primOpTag CasMutVarOp = 561 -primOpTag CatchOp = 562 -primOpTag RaiseOp = 563 -primOpTag RaiseUnderflowOp = 564 -primOpTag RaiseOverflowOp = 565 -primOpTag RaiseDivZeroOp = 566 -primOpTag RaiseIOOp = 567 -primOpTag MaskAsyncExceptionsOp = 568 -primOpTag MaskUninterruptibleOp = 569 -primOpTag UnmaskAsyncExceptionsOp = 570 -primOpTag MaskStatus = 571 -primOpTag NewPromptTagOp = 572 -primOpTag PromptOp = 573 -primOpTag Control0Op = 574 -primOpTag AtomicallyOp = 575 -primOpTag RetryOp = 576 -primOpTag CatchRetryOp = 577 -primOpTag CatchSTMOp = 578 -primOpTag NewTVarOp = 579 -primOpTag ReadTVarOp = 580 -primOpTag ReadTVarIOOp = 581 -primOpTag WriteTVarOp = 582 -primOpTag NewMVarOp = 583 -primOpTag TakeMVarOp = 584 -primOpTag TryTakeMVarOp = 585 -primOpTag PutMVarOp = 586 -primOpTag TryPutMVarOp = 587 -primOpTag ReadMVarOp = 588 -primOpTag TryReadMVarOp = 589 -primOpTag IsEmptyMVarOp = 590 -primOpTag NewIOPortOp = 591 -primOpTag ReadIOPortOp = 592 -primOpTag WriteIOPortOp = 593 -primOpTag DelayOp = 594 -primOpTag WaitReadOp = 595 -primOpTag WaitWriteOp = 596 -primOpTag ForkOp = 597 -primOpTag ForkOnOp = 598 -primOpTag KillThreadOp = 599 -primOpTag YieldOp = 600 -primOpTag MyThreadIdOp = 601 -primOpTag LabelThreadOp = 602 -primOpTag IsCurrentThreadBoundOp = 603 -primOpTag NoDuplicateOp = 604 -primOpTag GetThreadLabelOp = 605 -primOpTag ThreadStatusOp = 606 -primOpTag ListThreadsOp = 607 -primOpTag MkWeakOp = 608 -primOpTag MkWeakNoFinalizerOp = 609 -primOpTag AddCFinalizerToWeakOp = 610 -primOpTag DeRefWeakOp = 611 -primOpTag FinalizeWeakOp = 612 -primOpTag TouchOp = 613 -primOpTag MakeStablePtrOp = 614 -primOpTag DeRefStablePtrOp = 615 -primOpTag EqStablePtrOp = 616 -primOpTag MakeStableNameOp = 617 -primOpTag StableNameToIntOp = 618 -primOpTag CompactNewOp = 619 -primOpTag CompactResizeOp = 620 -primOpTag CompactContainsOp = 621 -primOpTag CompactContainsAnyOp = 622 -primOpTag CompactGetFirstBlockOp = 623 -primOpTag CompactGetNextBlockOp = 624 -primOpTag CompactAllocateBlockOp = 625 -primOpTag CompactFixupPointersOp = 626 -primOpTag CompactAdd = 627 -primOpTag CompactAddWithSharing = 628 -primOpTag CompactSize = 629 -primOpTag ReallyUnsafePtrEqualityOp = 630 -primOpTag ParOp = 631 -primOpTag SparkOp = 632 -primOpTag SeqOp = 633 -primOpTag GetSparkOp = 634 -primOpTag NumSparks = 635 -primOpTag KeepAliveOp = 636 -primOpTag DataToTagOp = 637 -primOpTag TagToEnumOp = 638 -primOpTag AddrToAnyOp = 639 -primOpTag AnyToAddrOp = 640 -primOpTag MkApUpd0_Op = 641 -primOpTag NewBCOOp = 642 -primOpTag UnpackClosureOp = 643 -primOpTag ClosureSizeOp = 644 -primOpTag GetApStackValOp = 645 -primOpTag GetCCSOfOp = 646 -primOpTag GetCurrentCCSOp = 647 -primOpTag ClearCCSOp = 648 -primOpTag WhereFromOp = 649 -primOpTag TraceEventOp = 650 -primOpTag TraceEventBinaryOp = 651 -primOpTag TraceMarkerOp = 652 -primOpTag SetThreadAllocationCounter = 653 -primOpTag (VecBroadcastOp IntVec 16 W8) = 654 -primOpTag (VecBroadcastOp IntVec 8 W16) = 655 -primOpTag (VecBroadcastOp IntVec 4 W32) = 656 -primOpTag (VecBroadcastOp IntVec 2 W64) = 657 -primOpTag (VecBroadcastOp IntVec 32 W8) = 658 -primOpTag (VecBroadcastOp IntVec 16 W16) = 659 -primOpTag (VecBroadcastOp IntVec 8 W32) = 660 -primOpTag (VecBroadcastOp IntVec 4 W64) = 661 -primOpTag (VecBroadcastOp IntVec 64 W8) = 662 -primOpTag (VecBroadcastOp IntVec 32 W16) = 663 -primOpTag (VecBroadcastOp IntVec 16 W32) = 664 -primOpTag (VecBroadcastOp IntVec 8 W64) = 665 -primOpTag (VecBroadcastOp WordVec 16 W8) = 666 -primOpTag (VecBroadcastOp WordVec 8 W16) = 667 -primOpTag (VecBroadcastOp WordVec 4 W32) = 668 -primOpTag (VecBroadcastOp WordVec 2 W64) = 669 -primOpTag (VecBroadcastOp WordVec 32 W8) = 670 -primOpTag (VecBroadcastOp WordVec 16 W16) = 671 -primOpTag (VecBroadcastOp WordVec 8 W32) = 672 -primOpTag (VecBroadcastOp WordVec 4 W64) = 673 -primOpTag (VecBroadcastOp WordVec 64 W8) = 674 -primOpTag (VecBroadcastOp WordVec 32 W16) = 675 -primOpTag (VecBroadcastOp WordVec 16 W32) = 676 -primOpTag (VecBroadcastOp WordVec 8 W64) = 677 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 678 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 679 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 680 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 681 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 682 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 683 -primOpTag (VecPackOp IntVec 16 W8) = 684 -primOpTag (VecPackOp IntVec 8 W16) = 685 -primOpTag (VecPackOp IntVec 4 W32) = 686 -primOpTag (VecPackOp IntVec 2 W64) = 687 -primOpTag (VecPackOp IntVec 32 W8) = 688 -primOpTag (VecPackOp IntVec 16 W16) = 689 -primOpTag (VecPackOp IntVec 8 W32) = 690 -primOpTag (VecPackOp IntVec 4 W64) = 691 -primOpTag (VecPackOp IntVec 64 W8) = 692 -primOpTag (VecPackOp IntVec 32 W16) = 693 -primOpTag (VecPackOp IntVec 16 W32) = 694 -primOpTag (VecPackOp IntVec 8 W64) = 695 -primOpTag (VecPackOp WordVec 16 W8) = 696 -primOpTag (VecPackOp WordVec 8 W16) = 697 -primOpTag (VecPackOp WordVec 4 W32) = 698 -primOpTag (VecPackOp WordVec 2 W64) = 699 -primOpTag (VecPackOp WordVec 32 W8) = 700 -primOpTag (VecPackOp WordVec 16 W16) = 701 -primOpTag (VecPackOp WordVec 8 W32) = 702 -primOpTag (VecPackOp WordVec 4 W64) = 703 -primOpTag (VecPackOp WordVec 64 W8) = 704 -primOpTag (VecPackOp WordVec 32 W16) = 705 -primOpTag (VecPackOp WordVec 16 W32) = 706 -primOpTag (VecPackOp WordVec 8 W64) = 707 -primOpTag (VecPackOp FloatVec 4 W32) = 708 -primOpTag (VecPackOp FloatVec 2 W64) = 709 -primOpTag (VecPackOp FloatVec 8 W32) = 710 -primOpTag (VecPackOp FloatVec 4 W64) = 711 -primOpTag (VecPackOp FloatVec 16 W32) = 712 -primOpTag (VecPackOp FloatVec 8 W64) = 713 -primOpTag (VecUnpackOp IntVec 16 W8) = 714 -primOpTag (VecUnpackOp IntVec 8 W16) = 715 -primOpTag (VecUnpackOp IntVec 4 W32) = 716 -primOpTag (VecUnpackOp IntVec 2 W64) = 717 -primOpTag (VecUnpackOp IntVec 32 W8) = 718 -primOpTag (VecUnpackOp IntVec 16 W16) = 719 -primOpTag (VecUnpackOp IntVec 8 W32) = 720 -primOpTag (VecUnpackOp IntVec 4 W64) = 721 -primOpTag (VecUnpackOp IntVec 64 W8) = 722 -primOpTag (VecUnpackOp IntVec 32 W16) = 723 -primOpTag (VecUnpackOp IntVec 16 W32) = 724 -primOpTag (VecUnpackOp IntVec 8 W64) = 725 -primOpTag (VecUnpackOp WordVec 16 W8) = 726 -primOpTag (VecUnpackOp WordVec 8 W16) = 727 -primOpTag (VecUnpackOp WordVec 4 W32) = 728 -primOpTag (VecUnpackOp WordVec 2 W64) = 729 -primOpTag (VecUnpackOp WordVec 32 W8) = 730 -primOpTag (VecUnpackOp WordVec 16 W16) = 731 -primOpTag (VecUnpackOp WordVec 8 W32) = 732 -primOpTag (VecUnpackOp WordVec 4 W64) = 733 -primOpTag (VecUnpackOp WordVec 64 W8) = 734 -primOpTag (VecUnpackOp WordVec 32 W16) = 735 -primOpTag (VecUnpackOp WordVec 16 W32) = 736 -primOpTag (VecUnpackOp WordVec 8 W64) = 737 -primOpTag (VecUnpackOp FloatVec 4 W32) = 738 -primOpTag (VecUnpackOp FloatVec 2 W64) = 739 -primOpTag (VecUnpackOp FloatVec 8 W32) = 740 -primOpTag (VecUnpackOp FloatVec 4 W64) = 741 -primOpTag (VecUnpackOp FloatVec 16 W32) = 742 -primOpTag (VecUnpackOp FloatVec 8 W64) = 743 -primOpTag (VecInsertOp IntVec 16 W8) = 744 -primOpTag (VecInsertOp IntVec 8 W16) = 745 -primOpTag (VecInsertOp IntVec 4 W32) = 746 -primOpTag (VecInsertOp IntVec 2 W64) = 747 -primOpTag (VecInsertOp IntVec 32 W8) = 748 -primOpTag (VecInsertOp IntVec 16 W16) = 749 -primOpTag (VecInsertOp IntVec 8 W32) = 750 -primOpTag (VecInsertOp IntVec 4 W64) = 751 -primOpTag (VecInsertOp IntVec 64 W8) = 752 -primOpTag (VecInsertOp IntVec 32 W16) = 753 -primOpTag (VecInsertOp IntVec 16 W32) = 754 -primOpTag (VecInsertOp IntVec 8 W64) = 755 -primOpTag (VecInsertOp WordVec 16 W8) = 756 -primOpTag (VecInsertOp WordVec 8 W16) = 757 -primOpTag (VecInsertOp WordVec 4 W32) = 758 -primOpTag (VecInsertOp WordVec 2 W64) = 759 -primOpTag (VecInsertOp WordVec 32 W8) = 760 -primOpTag (VecInsertOp WordVec 16 W16) = 761 -primOpTag (VecInsertOp WordVec 8 W32) = 762 -primOpTag (VecInsertOp WordVec 4 W64) = 763 -primOpTag (VecInsertOp WordVec 64 W8) = 764 -primOpTag (VecInsertOp WordVec 32 W16) = 765 -primOpTag (VecInsertOp WordVec 16 W32) = 766 -primOpTag (VecInsertOp WordVec 8 W64) = 767 -primOpTag (VecInsertOp FloatVec 4 W32) = 768 -primOpTag (VecInsertOp FloatVec 2 W64) = 769 -primOpTag (VecInsertOp FloatVec 8 W32) = 770 -primOpTag (VecInsertOp FloatVec 4 W64) = 771 -primOpTag (VecInsertOp FloatVec 16 W32) = 772 -primOpTag (VecInsertOp FloatVec 8 W64) = 773 -primOpTag (VecAddOp IntVec 16 W8) = 774 -primOpTag (VecAddOp IntVec 8 W16) = 775 -primOpTag (VecAddOp IntVec 4 W32) = 776 -primOpTag (VecAddOp IntVec 2 W64) = 777 -primOpTag (VecAddOp IntVec 32 W8) = 778 -primOpTag (VecAddOp IntVec 16 W16) = 779 -primOpTag (VecAddOp IntVec 8 W32) = 780 -primOpTag (VecAddOp IntVec 4 W64) = 781 -primOpTag (VecAddOp IntVec 64 W8) = 782 -primOpTag (VecAddOp IntVec 32 W16) = 783 -primOpTag (VecAddOp IntVec 16 W32) = 784 -primOpTag (VecAddOp IntVec 8 W64) = 785 -primOpTag (VecAddOp WordVec 16 W8) = 786 -primOpTag (VecAddOp WordVec 8 W16) = 787 -primOpTag (VecAddOp WordVec 4 W32) = 788 -primOpTag (VecAddOp WordVec 2 W64) = 789 -primOpTag (VecAddOp WordVec 32 W8) = 790 -primOpTag (VecAddOp WordVec 16 W16) = 791 -primOpTag (VecAddOp WordVec 8 W32) = 792 -primOpTag (VecAddOp WordVec 4 W64) = 793 -primOpTag (VecAddOp WordVec 64 W8) = 794 -primOpTag (VecAddOp WordVec 32 W16) = 795 -primOpTag (VecAddOp WordVec 16 W32) = 796 -primOpTag (VecAddOp WordVec 8 W64) = 797 -primOpTag (VecAddOp FloatVec 4 W32) = 798 -primOpTag (VecAddOp FloatVec 2 W64) = 799 -primOpTag (VecAddOp FloatVec 8 W32) = 800 -primOpTag (VecAddOp FloatVec 4 W64) = 801 -primOpTag (VecAddOp FloatVec 16 W32) = 802 -primOpTag (VecAddOp FloatVec 8 W64) = 803 -primOpTag (VecSubOp IntVec 16 W8) = 804 -primOpTag (VecSubOp IntVec 8 W16) = 805 -primOpTag (VecSubOp IntVec 4 W32) = 806 -primOpTag (VecSubOp IntVec 2 W64) = 807 -primOpTag (VecSubOp IntVec 32 W8) = 808 -primOpTag (VecSubOp IntVec 16 W16) = 809 -primOpTag (VecSubOp IntVec 8 W32) = 810 -primOpTag (VecSubOp IntVec 4 W64) = 811 -primOpTag (VecSubOp IntVec 64 W8) = 812 -primOpTag (VecSubOp IntVec 32 W16) = 813 -primOpTag (VecSubOp IntVec 16 W32) = 814 -primOpTag (VecSubOp IntVec 8 W64) = 815 -primOpTag (VecSubOp WordVec 16 W8) = 816 -primOpTag (VecSubOp WordVec 8 W16) = 817 -primOpTag (VecSubOp WordVec 4 W32) = 818 -primOpTag (VecSubOp WordVec 2 W64) = 819 -primOpTag (VecSubOp WordVec 32 W8) = 820 -primOpTag (VecSubOp WordVec 16 W16) = 821 -primOpTag (VecSubOp WordVec 8 W32) = 822 -primOpTag (VecSubOp WordVec 4 W64) = 823 -primOpTag (VecSubOp WordVec 64 W8) = 824 -primOpTag (VecSubOp WordVec 32 W16) = 825 -primOpTag (VecSubOp WordVec 16 W32) = 826 -primOpTag (VecSubOp WordVec 8 W64) = 827 -primOpTag (VecSubOp FloatVec 4 W32) = 828 -primOpTag (VecSubOp FloatVec 2 W64) = 829 -primOpTag (VecSubOp FloatVec 8 W32) = 830 -primOpTag (VecSubOp FloatVec 4 W64) = 831 -primOpTag (VecSubOp FloatVec 16 W32) = 832 -primOpTag (VecSubOp FloatVec 8 W64) = 833 -primOpTag (VecMulOp IntVec 16 W8) = 834 -primOpTag (VecMulOp IntVec 8 W16) = 835 -primOpTag (VecMulOp IntVec 4 W32) = 836 -primOpTag (VecMulOp IntVec 2 W64) = 837 -primOpTag (VecMulOp IntVec 32 W8) = 838 -primOpTag (VecMulOp IntVec 16 W16) = 839 -primOpTag (VecMulOp IntVec 8 W32) = 840 -primOpTag (VecMulOp IntVec 4 W64) = 841 -primOpTag (VecMulOp IntVec 64 W8) = 842 -primOpTag (VecMulOp IntVec 32 W16) = 843 -primOpTag (VecMulOp IntVec 16 W32) = 844 -primOpTag (VecMulOp IntVec 8 W64) = 845 -primOpTag (VecMulOp WordVec 16 W8) = 846 -primOpTag (VecMulOp WordVec 8 W16) = 847 -primOpTag (VecMulOp WordVec 4 W32) = 848 -primOpTag (VecMulOp WordVec 2 W64) = 849 -primOpTag (VecMulOp WordVec 32 W8) = 850 -primOpTag (VecMulOp WordVec 16 W16) = 851 -primOpTag (VecMulOp WordVec 8 W32) = 852 -primOpTag (VecMulOp WordVec 4 W64) = 853 -primOpTag (VecMulOp WordVec 64 W8) = 854 -primOpTag (VecMulOp WordVec 32 W16) = 855 -primOpTag (VecMulOp WordVec 16 W32) = 856 -primOpTag (VecMulOp WordVec 8 W64) = 857 -primOpTag (VecMulOp FloatVec 4 W32) = 858 -primOpTag (VecMulOp FloatVec 2 W64) = 859 -primOpTag (VecMulOp FloatVec 8 W32) = 860 -primOpTag (VecMulOp FloatVec 4 W64) = 861 -primOpTag (VecMulOp FloatVec 16 W32) = 862 -primOpTag (VecMulOp FloatVec 8 W64) = 863 -primOpTag (VecDivOp FloatVec 4 W32) = 864 -primOpTag (VecDivOp FloatVec 2 W64) = 865 -primOpTag (VecDivOp FloatVec 8 W32) = 866 -primOpTag (VecDivOp FloatVec 4 W64) = 867 -primOpTag (VecDivOp FloatVec 16 W32) = 868 -primOpTag (VecDivOp FloatVec 8 W64) = 869 -primOpTag (VecQuotOp IntVec 16 W8) = 870 -primOpTag (VecQuotOp IntVec 8 W16) = 871 -primOpTag (VecQuotOp IntVec 4 W32) = 872 -primOpTag (VecQuotOp IntVec 2 W64) = 873 -primOpTag (VecQuotOp IntVec 32 W8) = 874 -primOpTag (VecQuotOp IntVec 16 W16) = 875 -primOpTag (VecQuotOp IntVec 8 W32) = 876 -primOpTag (VecQuotOp IntVec 4 W64) = 877 -primOpTag (VecQuotOp IntVec 64 W8) = 878 -primOpTag (VecQuotOp IntVec 32 W16) = 879 -primOpTag (VecQuotOp IntVec 16 W32) = 880 -primOpTag (VecQuotOp IntVec 8 W64) = 881 -primOpTag (VecQuotOp WordVec 16 W8) = 882 -primOpTag (VecQuotOp WordVec 8 W16) = 883 -primOpTag (VecQuotOp WordVec 4 W32) = 884 -primOpTag (VecQuotOp WordVec 2 W64) = 885 -primOpTag (VecQuotOp WordVec 32 W8) = 886 -primOpTag (VecQuotOp WordVec 16 W16) = 887 -primOpTag (VecQuotOp WordVec 8 W32) = 888 -primOpTag (VecQuotOp WordVec 4 W64) = 889 -primOpTag (VecQuotOp WordVec 64 W8) = 890 -primOpTag (VecQuotOp WordVec 32 W16) = 891 -primOpTag (VecQuotOp WordVec 16 W32) = 892 -primOpTag (VecQuotOp WordVec 8 W64) = 893 -primOpTag (VecRemOp IntVec 16 W8) = 894 -primOpTag (VecRemOp IntVec 8 W16) = 895 -primOpTag (VecRemOp IntVec 4 W32) = 896 -primOpTag (VecRemOp IntVec 2 W64) = 897 -primOpTag (VecRemOp IntVec 32 W8) = 898 -primOpTag (VecRemOp IntVec 16 W16) = 899 -primOpTag (VecRemOp IntVec 8 W32) = 900 -primOpTag (VecRemOp IntVec 4 W64) = 901 -primOpTag (VecRemOp IntVec 64 W8) = 902 -primOpTag (VecRemOp IntVec 32 W16) = 903 -primOpTag (VecRemOp IntVec 16 W32) = 904 -primOpTag (VecRemOp IntVec 8 W64) = 905 -primOpTag (VecRemOp WordVec 16 W8) = 906 -primOpTag (VecRemOp WordVec 8 W16) = 907 -primOpTag (VecRemOp WordVec 4 W32) = 908 -primOpTag (VecRemOp WordVec 2 W64) = 909 -primOpTag (VecRemOp WordVec 32 W8) = 910 -primOpTag (VecRemOp WordVec 16 W16) = 911 -primOpTag (VecRemOp WordVec 8 W32) = 912 -primOpTag (VecRemOp WordVec 4 W64) = 913 -primOpTag (VecRemOp WordVec 64 W8) = 914 -primOpTag (VecRemOp WordVec 32 W16) = 915 -primOpTag (VecRemOp WordVec 16 W32) = 916 -primOpTag (VecRemOp WordVec 8 W64) = 917 -primOpTag (VecNegOp IntVec 16 W8) = 918 -primOpTag (VecNegOp IntVec 8 W16) = 919 -primOpTag (VecNegOp IntVec 4 W32) = 920 -primOpTag (VecNegOp IntVec 2 W64) = 921 -primOpTag (VecNegOp IntVec 32 W8) = 922 -primOpTag (VecNegOp IntVec 16 W16) = 923 -primOpTag (VecNegOp IntVec 8 W32) = 924 -primOpTag (VecNegOp IntVec 4 W64) = 925 -primOpTag (VecNegOp IntVec 64 W8) = 926 -primOpTag (VecNegOp IntVec 32 W16) = 927 -primOpTag (VecNegOp IntVec 16 W32) = 928 -primOpTag (VecNegOp IntVec 8 W64) = 929 -primOpTag (VecNegOp FloatVec 4 W32) = 930 -primOpTag (VecNegOp FloatVec 2 W64) = 931 -primOpTag (VecNegOp FloatVec 8 W32) = 932 -primOpTag (VecNegOp FloatVec 4 W64) = 933 -primOpTag (VecNegOp FloatVec 16 W32) = 934 -primOpTag (VecNegOp FloatVec 8 W64) = 935 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 936 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 937 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 938 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 939 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 940 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 941 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 942 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 943 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 944 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 945 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 946 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 947 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 948 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 949 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 950 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 951 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 952 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 953 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 954 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 955 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 956 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 957 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 958 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 959 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 960 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 961 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 962 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 963 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 964 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 965 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 966 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 967 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 968 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 969 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 970 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 971 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 972 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 973 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 974 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 975 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 976 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 977 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 978 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 979 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 980 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 981 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 982 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 983 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 984 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 985 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 986 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 987 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 988 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 989 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 990 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 991 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 992 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 993 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 994 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 995 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 996 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 997 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 998 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 999 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1000 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1001 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1002 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1003 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1004 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1005 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1006 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1007 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1008 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1009 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1010 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1011 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1012 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1013 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1014 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1015 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1016 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1017 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1018 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1019 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1020 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1021 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1022 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1023 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1024 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1025 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1026 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1027 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1028 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1029 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1030 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1031 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1032 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1033 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1034 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1035 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1036 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1037 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1038 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1039 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1040 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1041 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1042 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1043 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1044 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1045 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1046 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1047 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1048 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1049 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1050 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1051 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1052 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1053 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1054 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1055 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1056 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1057 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1058 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1059 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1060 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1061 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1062 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1063 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1064 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1065 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1066 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1067 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1068 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1069 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1070 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1071 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1072 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1073 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1074 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1075 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1076 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1077 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1078 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1079 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1080 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1081 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1082 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1083 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1084 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1085 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1086 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1087 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1088 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1089 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1090 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1091 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1092 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1093 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1094 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1095 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1096 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1097 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1098 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1099 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1100 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1101 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1102 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1103 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1104 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1105 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1106 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1107 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1108 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1109 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1110 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1111 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1112 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1113 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1114 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1115 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1116 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1117 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1118 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1119 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1120 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1121 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1122 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1123 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1124 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1125 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1126 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1127 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1128 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1129 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1130 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1131 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1132 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1133 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1134 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1135 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1136 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1137 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1138 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1139 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1140 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1141 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1142 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1143 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1144 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1145 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1146 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1147 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1148 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1149 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1150 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1151 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1152 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1153 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1154 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1155 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1156 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1157 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1158 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1159 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1160 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1161 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1162 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1163 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1164 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1165 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1166 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1167 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1168 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1169 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1170 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1171 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1172 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1173 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1174 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1175 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1176 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1177 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1178 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1179 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1180 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1181 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1182 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1183 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1184 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1185 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1186 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1187 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1188 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1189 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1190 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1191 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1192 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1193 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1194 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1195 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1196 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1197 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1198 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1199 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1200 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1201 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1202 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1203 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1204 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1205 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1206 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1207 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1208 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1209 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1210 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1211 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1212 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1213 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1214 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1215 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1216 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1217 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1218 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1219 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1220 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1221 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1222 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1223 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1224 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1225 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1226 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1227 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1228 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1229 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1230 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1231 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1232 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1233 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1234 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1235 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1236 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1237 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1238 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1239 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1240 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1241 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1242 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1243 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1244 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1245 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1246 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1247 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1248 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1249 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1250 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1251 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1252 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1253 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1254 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1255 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1256 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1257 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1258 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1259 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1260 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1261 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1262 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1263 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1264 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1265 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1266 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1267 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1268 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1269 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1270 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1271 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1272 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1273 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1274 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1275 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1276 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1277 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1278 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1279 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1280 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1281 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1282 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1283 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1284 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1285 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1286 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1287 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1288 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1289 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1290 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1291 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1292 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1293 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1294 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1295 -primOpTag PrefetchByteArrayOp3 = 1296 -primOpTag PrefetchMutableByteArrayOp3 = 1297 -primOpTag PrefetchAddrOp3 = 1298 -primOpTag PrefetchValueOp3 = 1299 -primOpTag PrefetchByteArrayOp2 = 1300 -primOpTag PrefetchMutableByteArrayOp2 = 1301 -primOpTag PrefetchAddrOp2 = 1302 -primOpTag PrefetchValueOp2 = 1303 -primOpTag PrefetchByteArrayOp1 = 1304 -primOpTag PrefetchMutableByteArrayOp1 = 1305 -primOpTag PrefetchAddrOp1 = 1306 -primOpTag PrefetchValueOp1 = 1307 -primOpTag PrefetchByteArrayOp0 = 1308 -primOpTag PrefetchMutableByteArrayOp0 = 1309 -primOpTag PrefetchAddrOp0 = 1310 -primOpTag PrefetchValueOp0 = 1311 +maxPrimOpTag = 1324 +primOpTag :: PrimOp -> Int +primOpTag CharGtOp = 0 +primOpTag CharGeOp = 1 +primOpTag CharEqOp = 2 +primOpTag CharNeOp = 3 +primOpTag CharLtOp = 4 +primOpTag CharLeOp = 5 +primOpTag OrdOp = 6 +primOpTag Int8ToIntOp = 7 +primOpTag IntToInt8Op = 8 +primOpTag Int8NegOp = 9 +primOpTag Int8AddOp = 10 +primOpTag Int8SubOp = 11 +primOpTag Int8MulOp = 12 +primOpTag Int8QuotOp = 13 +primOpTag Int8RemOp = 14 +primOpTag Int8QuotRemOp = 15 +primOpTag Int8SllOp = 16 +primOpTag Int8SraOp = 17 +primOpTag Int8SrlOp = 18 +primOpTag Int8ToWord8Op = 19 +primOpTag Int8EqOp = 20 +primOpTag Int8GeOp = 21 +primOpTag Int8GtOp = 22 +primOpTag Int8LeOp = 23 +primOpTag Int8LtOp = 24 +primOpTag Int8NeOp = 25 +primOpTag Word8ToWordOp = 26 +primOpTag WordToWord8Op = 27 +primOpTag Word8AddOp = 28 +primOpTag Word8SubOp = 29 +primOpTag Word8MulOp = 30 +primOpTag Word8QuotOp = 31 +primOpTag Word8RemOp = 32 +primOpTag Word8QuotRemOp = 33 +primOpTag Word8AndOp = 34 +primOpTag Word8OrOp = 35 +primOpTag Word8XorOp = 36 +primOpTag Word8NotOp = 37 +primOpTag Word8SllOp = 38 +primOpTag Word8SrlOp = 39 +primOpTag Word8ToInt8Op = 40 +primOpTag Word8EqOp = 41 +primOpTag Word8GeOp = 42 +primOpTag Word8GtOp = 43 +primOpTag Word8LeOp = 44 +primOpTag Word8LtOp = 45 +primOpTag Word8NeOp = 46 +primOpTag Int16ToIntOp = 47 +primOpTag IntToInt16Op = 48 +primOpTag Int16NegOp = 49 +primOpTag Int16AddOp = 50 +primOpTag Int16SubOp = 51 +primOpTag Int16MulOp = 52 +primOpTag Int16QuotOp = 53 +primOpTag Int16RemOp = 54 +primOpTag Int16QuotRemOp = 55 +primOpTag Int16SllOp = 56 +primOpTag Int16SraOp = 57 +primOpTag Int16SrlOp = 58 +primOpTag Int16ToWord16Op = 59 +primOpTag Int16EqOp = 60 +primOpTag Int16GeOp = 61 +primOpTag Int16GtOp = 62 +primOpTag Int16LeOp = 63 +primOpTag Int16LtOp = 64 +primOpTag Int16NeOp = 65 +primOpTag Word16ToWordOp = 66 +primOpTag WordToWord16Op = 67 +primOpTag Word16AddOp = 68 +primOpTag Word16SubOp = 69 +primOpTag Word16MulOp = 70 +primOpTag Word16QuotOp = 71 +primOpTag Word16RemOp = 72 +primOpTag Word16QuotRemOp = 73 +primOpTag Word16AndOp = 74 +primOpTag Word16OrOp = 75 +primOpTag Word16XorOp = 76 +primOpTag Word16NotOp = 77 +primOpTag Word16SllOp = 78 +primOpTag Word16SrlOp = 79 +primOpTag Word16ToInt16Op = 80 +primOpTag Word16EqOp = 81 +primOpTag Word16GeOp = 82 +primOpTag Word16GtOp = 83 +primOpTag Word16LeOp = 84 +primOpTag Word16LtOp = 85 +primOpTag Word16NeOp = 86 +primOpTag Int32ToIntOp = 87 +primOpTag IntToInt32Op = 88 +primOpTag Int32NegOp = 89 +primOpTag Int32AddOp = 90 +primOpTag Int32SubOp = 91 +primOpTag Int32MulOp = 92 +primOpTag Int32QuotOp = 93 +primOpTag Int32RemOp = 94 +primOpTag Int32QuotRemOp = 95 +primOpTag Int32SllOp = 96 +primOpTag Int32SraOp = 97 +primOpTag Int32SrlOp = 98 +primOpTag Int32ToWord32Op = 99 +primOpTag Int32EqOp = 100 +primOpTag Int32GeOp = 101 +primOpTag Int32GtOp = 102 +primOpTag Int32LeOp = 103 +primOpTag Int32LtOp = 104 +primOpTag Int32NeOp = 105 +primOpTag Word32ToWordOp = 106 +primOpTag WordToWord32Op = 107 +primOpTag Word32AddOp = 108 +primOpTag Word32SubOp = 109 +primOpTag Word32MulOp = 110 +primOpTag Word32QuotOp = 111 +primOpTag Word32RemOp = 112 +primOpTag Word32QuotRemOp = 113 +primOpTag Word32AndOp = 114 +primOpTag Word32OrOp = 115 +primOpTag Word32XorOp = 116 +primOpTag Word32NotOp = 117 +primOpTag Word32SllOp = 118 +primOpTag Word32SrlOp = 119 +primOpTag Word32ToInt32Op = 120 +primOpTag Word32EqOp = 121 +primOpTag Word32GeOp = 122 +primOpTag Word32GtOp = 123 +primOpTag Word32LeOp = 124 +primOpTag Word32LtOp = 125 +primOpTag Word32NeOp = 126 +primOpTag Int64ToIntOp = 127 +primOpTag IntToInt64Op = 128 +primOpTag Int64NegOp = 129 +primOpTag Int64AddOp = 130 +primOpTag Int64SubOp = 131 +primOpTag Int64MulOp = 132 +primOpTag Int64QuotOp = 133 +primOpTag Int64RemOp = 134 +primOpTag Int64SllOp = 135 +primOpTag Int64SraOp = 136 +primOpTag Int64SrlOp = 137 +primOpTag Int64ToWord64Op = 138 +primOpTag Int64EqOp = 139 +primOpTag Int64GeOp = 140 +primOpTag Int64GtOp = 141 +primOpTag Int64LeOp = 142 +primOpTag Int64LtOp = 143 +primOpTag Int64NeOp = 144 +primOpTag Word64ToWordOp = 145 +primOpTag WordToWord64Op = 146 +primOpTag Word64AddOp = 147 +primOpTag Word64SubOp = 148 +primOpTag Word64MulOp = 149 +primOpTag Word64QuotOp = 150 +primOpTag Word64RemOp = 151 +primOpTag Word64AndOp = 152 +primOpTag Word64OrOp = 153 +primOpTag Word64XorOp = 154 +primOpTag Word64NotOp = 155 +primOpTag Word64SllOp = 156 +primOpTag Word64SrlOp = 157 +primOpTag Word64ToInt64Op = 158 +primOpTag Word64EqOp = 159 +primOpTag Word64GeOp = 160 +primOpTag Word64GtOp = 161 +primOpTag Word64LeOp = 162 +primOpTag Word64LtOp = 163 +primOpTag Word64NeOp = 164 +primOpTag IntAddOp = 165 +primOpTag IntSubOp = 166 +primOpTag IntMulOp = 167 +primOpTag IntMul2Op = 168 +primOpTag IntMulMayOfloOp = 169 +primOpTag IntQuotOp = 170 +primOpTag IntRemOp = 171 +primOpTag IntQuotRemOp = 172 +primOpTag IntAndOp = 173 +primOpTag IntOrOp = 174 +primOpTag IntXorOp = 175 +primOpTag IntNotOp = 176 +primOpTag IntNegOp = 177 +primOpTag IntAddCOp = 178 +primOpTag IntSubCOp = 179 +primOpTag IntGtOp = 180 +primOpTag IntGeOp = 181 +primOpTag IntEqOp = 182 +primOpTag IntNeOp = 183 +primOpTag IntLtOp = 184 +primOpTag IntLeOp = 185 +primOpTag ChrOp = 186 +primOpTag IntToWordOp = 187 +primOpTag IntToFloatOp = 188 +primOpTag IntToDoubleOp = 189 +primOpTag WordToFloatOp = 190 +primOpTag WordToDoubleOp = 191 +primOpTag IntSllOp = 192 +primOpTag IntSraOp = 193 +primOpTag IntSrlOp = 194 +primOpTag WordAddOp = 195 +primOpTag WordAddCOp = 196 +primOpTag WordSubCOp = 197 +primOpTag WordAdd2Op = 198 +primOpTag WordSubOp = 199 +primOpTag WordMulOp = 200 +primOpTag WordMul2Op = 201 +primOpTag WordQuotOp = 202 +primOpTag WordRemOp = 203 +primOpTag WordQuotRemOp = 204 +primOpTag WordQuotRem2Op = 205 +primOpTag WordAndOp = 206 +primOpTag WordOrOp = 207 +primOpTag WordXorOp = 208 +primOpTag WordNotOp = 209 +primOpTag WordSllOp = 210 +primOpTag WordSrlOp = 211 +primOpTag WordToIntOp = 212 +primOpTag WordGtOp = 213 +primOpTag WordGeOp = 214 +primOpTag WordEqOp = 215 +primOpTag WordNeOp = 216 +primOpTag WordLtOp = 217 +primOpTag WordLeOp = 218 +primOpTag PopCnt8Op = 219 +primOpTag PopCnt16Op = 220 +primOpTag PopCnt32Op = 221 +primOpTag PopCnt64Op = 222 +primOpTag PopCntOp = 223 +primOpTag Pdep8Op = 224 +primOpTag Pdep16Op = 225 +primOpTag Pdep32Op = 226 +primOpTag Pdep64Op = 227 +primOpTag PdepOp = 228 +primOpTag Pext8Op = 229 +primOpTag Pext16Op = 230 +primOpTag Pext32Op = 231 +primOpTag Pext64Op = 232 +primOpTag PextOp = 233 +primOpTag Clz8Op = 234 +primOpTag Clz16Op = 235 +primOpTag Clz32Op = 236 +primOpTag Clz64Op = 237 +primOpTag ClzOp = 238 +primOpTag Ctz8Op = 239 +primOpTag Ctz16Op = 240 +primOpTag Ctz32Op = 241 +primOpTag Ctz64Op = 242 +primOpTag CtzOp = 243 +primOpTag BSwap16Op = 244 +primOpTag BSwap32Op = 245 +primOpTag BSwap64Op = 246 +primOpTag BSwapOp = 247 +primOpTag BRev8Op = 248 +primOpTag BRev16Op = 249 +primOpTag BRev32Op = 250 +primOpTag BRev64Op = 251 +primOpTag BRevOp = 252 +primOpTag Narrow8IntOp = 253 +primOpTag Narrow16IntOp = 254 +primOpTag Narrow32IntOp = 255 +primOpTag Narrow8WordOp = 256 +primOpTag Narrow16WordOp = 257 +primOpTag Narrow32WordOp = 258 +primOpTag DoubleGtOp = 259 +primOpTag DoubleGeOp = 260 +primOpTag DoubleEqOp = 261 +primOpTag DoubleNeOp = 262 +primOpTag DoubleLtOp = 263 +primOpTag DoubleLeOp = 264 +primOpTag DoubleAddOp = 265 +primOpTag DoubleSubOp = 266 +primOpTag DoubleMulOp = 267 +primOpTag DoubleDivOp = 268 +primOpTag DoubleNegOp = 269 +primOpTag DoubleFabsOp = 270 +primOpTag DoubleToIntOp = 271 +primOpTag DoubleToFloatOp = 272 +primOpTag DoubleExpOp = 273 +primOpTag DoubleExpM1Op = 274 +primOpTag DoubleLogOp = 275 +primOpTag DoubleLog1POp = 276 +primOpTag DoubleSqrtOp = 277 +primOpTag DoubleSinOp = 278 +primOpTag DoubleCosOp = 279 +primOpTag DoubleTanOp = 280 +primOpTag DoubleAsinOp = 281 +primOpTag DoubleAcosOp = 282 +primOpTag DoubleAtanOp = 283 +primOpTag DoubleSinhOp = 284 +primOpTag DoubleCoshOp = 285 +primOpTag DoubleTanhOp = 286 +primOpTag DoubleAsinhOp = 287 +primOpTag DoubleAcoshOp = 288 +primOpTag DoubleAtanhOp = 289 +primOpTag DoublePowerOp = 290 +primOpTag DoubleDecode_2IntOp = 291 +primOpTag DoubleDecode_Int64Op = 292 +primOpTag FloatGtOp = 293 +primOpTag FloatGeOp = 294 +primOpTag FloatEqOp = 295 +primOpTag FloatNeOp = 296 +primOpTag FloatLtOp = 297 +primOpTag FloatLeOp = 298 +primOpTag FloatAddOp = 299 +primOpTag FloatSubOp = 300 +primOpTag FloatMulOp = 301 +primOpTag FloatDivOp = 302 +primOpTag FloatNegOp = 303 +primOpTag FloatFabsOp = 304 +primOpTag FloatToIntOp = 305 +primOpTag FloatExpOp = 306 +primOpTag FloatExpM1Op = 307 +primOpTag FloatLogOp = 308 +primOpTag FloatLog1POp = 309 +primOpTag FloatSqrtOp = 310 +primOpTag FloatSinOp = 311 +primOpTag FloatCosOp = 312 +primOpTag FloatTanOp = 313 +primOpTag FloatAsinOp = 314 +primOpTag FloatAcosOp = 315 +primOpTag FloatAtanOp = 316 +primOpTag FloatSinhOp = 317 +primOpTag FloatCoshOp = 318 +primOpTag FloatTanhOp = 319 +primOpTag FloatAsinhOp = 320 +primOpTag FloatAcoshOp = 321 +primOpTag FloatAtanhOp = 322 +primOpTag FloatPowerOp = 323 +primOpTag FloatToDoubleOp = 324 +primOpTag FloatDecode_IntOp = 325 +primOpTag FloatFMAdd = 326 +primOpTag FloatFMSub = 327 +primOpTag FloatFNMAdd = 328 +primOpTag FloatFNMSub = 329 +primOpTag DoubleFMAdd = 330 +primOpTag DoubleFMSub = 331 +primOpTag DoubleFNMAdd = 332 +primOpTag DoubleFNMSub = 333 +primOpTag NewArrayOp = 334 +primOpTag ReadArrayOp = 335 +primOpTag WriteArrayOp = 336 +primOpTag SizeofArrayOp = 337 +primOpTag SizeofMutableArrayOp = 338 +primOpTag IndexArrayOp = 339 +primOpTag UnsafeFreezeArrayOp = 340 +primOpTag UnsafeThawArrayOp = 341 +primOpTag CopyArrayOp = 342 +primOpTag CopyMutableArrayOp = 343 +primOpTag CloneArrayOp = 344 +primOpTag CloneMutableArrayOp = 345 +primOpTag FreezeArrayOp = 346 +primOpTag ThawArrayOp = 347 +primOpTag CasArrayOp = 348 +primOpTag NewSmallArrayOp = 349 +primOpTag ShrinkSmallMutableArrayOp_Char = 350 +primOpTag ReadSmallArrayOp = 351 +primOpTag WriteSmallArrayOp = 352 +primOpTag SizeofSmallArrayOp = 353 +primOpTag SizeofSmallMutableArrayOp = 354 +primOpTag GetSizeofSmallMutableArrayOp = 355 +primOpTag IndexSmallArrayOp = 356 +primOpTag UnsafeFreezeSmallArrayOp = 357 +primOpTag UnsafeThawSmallArrayOp = 358 +primOpTag CopySmallArrayOp = 359 +primOpTag CopySmallMutableArrayOp = 360 +primOpTag CloneSmallArrayOp = 361 +primOpTag CloneSmallMutableArrayOp = 362 +primOpTag FreezeSmallArrayOp = 363 +primOpTag ThawSmallArrayOp = 364 +primOpTag CasSmallArrayOp = 365 +primOpTag NewByteArrayOp_Char = 366 +primOpTag NewPinnedByteArrayOp_Char = 367 +primOpTag NewAlignedPinnedByteArrayOp_Char = 368 +primOpTag MutableByteArrayIsPinnedOp = 369 +primOpTag ByteArrayIsPinnedOp = 370 +primOpTag ByteArrayContents_Char = 371 +primOpTag MutableByteArrayContents_Char = 372 +primOpTag ShrinkMutableByteArrayOp_Char = 373 +primOpTag ResizeMutableByteArrayOp_Char = 374 +primOpTag UnsafeFreezeByteArrayOp = 375 +primOpTag SizeofByteArrayOp = 376 +primOpTag SizeofMutableByteArrayOp = 377 +primOpTag GetSizeofMutableByteArrayOp = 378 +primOpTag IndexByteArrayOp_Char = 379 +primOpTag IndexByteArrayOp_WideChar = 380 +primOpTag IndexByteArrayOp_Int = 381 +primOpTag IndexByteArrayOp_Word = 382 +primOpTag IndexByteArrayOp_Addr = 383 +primOpTag IndexByteArrayOp_Float = 384 +primOpTag IndexByteArrayOp_Double = 385 +primOpTag IndexByteArrayOp_StablePtr = 386 +primOpTag IndexByteArrayOp_Int8 = 387 +primOpTag IndexByteArrayOp_Word8 = 388 +primOpTag IndexByteArrayOp_Int16 = 389 +primOpTag IndexByteArrayOp_Word16 = 390 +primOpTag IndexByteArrayOp_Int32 = 391 +primOpTag IndexByteArrayOp_Word32 = 392 +primOpTag IndexByteArrayOp_Int64 = 393 +primOpTag IndexByteArrayOp_Word64 = 394 +primOpTag IndexByteArrayOp_Word8AsChar = 395 +primOpTag IndexByteArrayOp_Word8AsWideChar = 396 +primOpTag IndexByteArrayOp_Word8AsInt = 397 +primOpTag IndexByteArrayOp_Word8AsWord = 398 +primOpTag IndexByteArrayOp_Word8AsAddr = 399 +primOpTag IndexByteArrayOp_Word8AsFloat = 400 +primOpTag IndexByteArrayOp_Word8AsDouble = 401 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 402 +primOpTag IndexByteArrayOp_Word8AsInt16 = 403 +primOpTag IndexByteArrayOp_Word8AsWord16 = 404 +primOpTag IndexByteArrayOp_Word8AsInt32 = 405 +primOpTag IndexByteArrayOp_Word8AsWord32 = 406 +primOpTag IndexByteArrayOp_Word8AsInt64 = 407 +primOpTag IndexByteArrayOp_Word8AsWord64 = 408 +primOpTag ReadByteArrayOp_Char = 409 +primOpTag ReadByteArrayOp_WideChar = 410 +primOpTag ReadByteArrayOp_Int = 411 +primOpTag ReadByteArrayOp_Word = 412 +primOpTag ReadByteArrayOp_Addr = 413 +primOpTag ReadByteArrayOp_Float = 414 +primOpTag ReadByteArrayOp_Double = 415 +primOpTag ReadByteArrayOp_StablePtr = 416 +primOpTag ReadByteArrayOp_Int8 = 417 +primOpTag ReadByteArrayOp_Word8 = 418 +primOpTag ReadByteArrayOp_Int16 = 419 +primOpTag ReadByteArrayOp_Word16 = 420 +primOpTag ReadByteArrayOp_Int32 = 421 +primOpTag ReadByteArrayOp_Word32 = 422 +primOpTag ReadByteArrayOp_Int64 = 423 +primOpTag ReadByteArrayOp_Word64 = 424 +primOpTag ReadByteArrayOp_Word8AsChar = 425 +primOpTag ReadByteArrayOp_Word8AsWideChar = 426 +primOpTag ReadByteArrayOp_Word8AsInt = 427 +primOpTag ReadByteArrayOp_Word8AsWord = 428 +primOpTag ReadByteArrayOp_Word8AsAddr = 429 +primOpTag ReadByteArrayOp_Word8AsFloat = 430 +primOpTag ReadByteArrayOp_Word8AsDouble = 431 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 432 +primOpTag ReadByteArrayOp_Word8AsInt16 = 433 +primOpTag ReadByteArrayOp_Word8AsWord16 = 434 +primOpTag ReadByteArrayOp_Word8AsInt32 = 435 +primOpTag ReadByteArrayOp_Word8AsWord32 = 436 +primOpTag ReadByteArrayOp_Word8AsInt64 = 437 +primOpTag ReadByteArrayOp_Word8AsWord64 = 438 +primOpTag WriteByteArrayOp_Char = 439 +primOpTag WriteByteArrayOp_WideChar = 440 +primOpTag WriteByteArrayOp_Int = 441 +primOpTag WriteByteArrayOp_Word = 442 +primOpTag WriteByteArrayOp_Addr = 443 +primOpTag WriteByteArrayOp_Float = 444 +primOpTag WriteByteArrayOp_Double = 445 +primOpTag WriteByteArrayOp_StablePtr = 446 +primOpTag WriteByteArrayOp_Int8 = 447 +primOpTag WriteByteArrayOp_Word8 = 448 +primOpTag WriteByteArrayOp_Int16 = 449 +primOpTag WriteByteArrayOp_Word16 = 450 +primOpTag WriteByteArrayOp_Int32 = 451 +primOpTag WriteByteArrayOp_Word32 = 452 +primOpTag WriteByteArrayOp_Int64 = 453 +primOpTag WriteByteArrayOp_Word64 = 454 +primOpTag WriteByteArrayOp_Word8AsChar = 455 +primOpTag WriteByteArrayOp_Word8AsWideChar = 456 +primOpTag WriteByteArrayOp_Word8AsInt = 457 +primOpTag WriteByteArrayOp_Word8AsWord = 458 +primOpTag WriteByteArrayOp_Word8AsAddr = 459 +primOpTag WriteByteArrayOp_Word8AsFloat = 460 +primOpTag WriteByteArrayOp_Word8AsDouble = 461 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 462 +primOpTag WriteByteArrayOp_Word8AsInt16 = 463 +primOpTag WriteByteArrayOp_Word8AsWord16 = 464 +primOpTag WriteByteArrayOp_Word8AsInt32 = 465 +primOpTag WriteByteArrayOp_Word8AsWord32 = 466 +primOpTag WriteByteArrayOp_Word8AsInt64 = 467 +primOpTag WriteByteArrayOp_Word8AsWord64 = 468 +primOpTag CompareByteArraysOp = 469 +primOpTag CopyByteArrayOp = 470 +primOpTag CopyMutableByteArrayOp = 471 +primOpTag CopyMutableByteArrayNonOverlappingOp = 472 +primOpTag CopyByteArrayToAddrOp = 473 +primOpTag CopyMutableByteArrayToAddrOp = 474 +primOpTag CopyAddrToByteArrayOp = 475 +primOpTag CopyAddrToAddrOp = 476 +primOpTag CopyAddrToAddrNonOverlappingOp = 477 +primOpTag SetByteArrayOp = 478 +primOpTag SetAddrRangeOp = 479 +primOpTag AtomicReadByteArrayOp_Int = 480 +primOpTag AtomicWriteByteArrayOp_Int = 481 +primOpTag CasByteArrayOp_Int = 482 +primOpTag CasByteArrayOp_Int8 = 483 +primOpTag CasByteArrayOp_Int16 = 484 +primOpTag CasByteArrayOp_Int32 = 485 +primOpTag CasByteArrayOp_Int64 = 486 +primOpTag FetchAddByteArrayOp_Int = 487 +primOpTag FetchSubByteArrayOp_Int = 488 +primOpTag FetchAndByteArrayOp_Int = 489 +primOpTag FetchNandByteArrayOp_Int = 490 +primOpTag FetchOrByteArrayOp_Int = 491 +primOpTag FetchXorByteArrayOp_Int = 492 +primOpTag AddrAddOp = 493 +primOpTag AddrSubOp = 494 +primOpTag AddrRemOp = 495 +primOpTag AddrToIntOp = 496 +primOpTag IntToAddrOp = 497 +primOpTag AddrGtOp = 498 +primOpTag AddrGeOp = 499 +primOpTag AddrEqOp = 500 +primOpTag AddrNeOp = 501 +primOpTag AddrLtOp = 502 +primOpTag AddrLeOp = 503 +primOpTag IndexOffAddrOp_Char = 504 +primOpTag IndexOffAddrOp_WideChar = 505 +primOpTag IndexOffAddrOp_Int = 506 +primOpTag IndexOffAddrOp_Word = 507 +primOpTag IndexOffAddrOp_Addr = 508 +primOpTag IndexOffAddrOp_Float = 509 +primOpTag IndexOffAddrOp_Double = 510 +primOpTag IndexOffAddrOp_StablePtr = 511 +primOpTag IndexOffAddrOp_Int8 = 512 +primOpTag IndexOffAddrOp_Word8 = 513 +primOpTag IndexOffAddrOp_Int16 = 514 +primOpTag IndexOffAddrOp_Word16 = 515 +primOpTag IndexOffAddrOp_Int32 = 516 +primOpTag IndexOffAddrOp_Word32 = 517 +primOpTag IndexOffAddrOp_Int64 = 518 +primOpTag IndexOffAddrOp_Word64 = 519 +primOpTag ReadOffAddrOp_Char = 520 +primOpTag ReadOffAddrOp_WideChar = 521 +primOpTag ReadOffAddrOp_Int = 522 +primOpTag ReadOffAddrOp_Word = 523 +primOpTag ReadOffAddrOp_Addr = 524 +primOpTag ReadOffAddrOp_Float = 525 +primOpTag ReadOffAddrOp_Double = 526 +primOpTag ReadOffAddrOp_StablePtr = 527 +primOpTag ReadOffAddrOp_Int8 = 528 +primOpTag ReadOffAddrOp_Word8 = 529 +primOpTag ReadOffAddrOp_Int16 = 530 +primOpTag ReadOffAddrOp_Word16 = 531 +primOpTag ReadOffAddrOp_Int32 = 532 +primOpTag ReadOffAddrOp_Word32 = 533 +primOpTag ReadOffAddrOp_Int64 = 534 +primOpTag ReadOffAddrOp_Word64 = 535 +primOpTag WriteOffAddrOp_Char = 536 +primOpTag WriteOffAddrOp_WideChar = 537 +primOpTag WriteOffAddrOp_Int = 538 +primOpTag WriteOffAddrOp_Word = 539 +primOpTag WriteOffAddrOp_Addr = 540 +primOpTag WriteOffAddrOp_Float = 541 +primOpTag WriteOffAddrOp_Double = 542 +primOpTag WriteOffAddrOp_StablePtr = 543 +primOpTag WriteOffAddrOp_Int8 = 544 +primOpTag WriteOffAddrOp_Word8 = 545 +primOpTag WriteOffAddrOp_Int16 = 546 +primOpTag WriteOffAddrOp_Word16 = 547 +primOpTag WriteOffAddrOp_Int32 = 548 +primOpTag WriteOffAddrOp_Word32 = 549 +primOpTag WriteOffAddrOp_Int64 = 550 +primOpTag WriteOffAddrOp_Word64 = 551 +primOpTag InterlockedExchange_Addr = 552 +primOpTag InterlockedExchange_Word = 553 +primOpTag CasAddrOp_Addr = 554 +primOpTag CasAddrOp_Word = 555 +primOpTag CasAddrOp_Word8 = 556 +primOpTag CasAddrOp_Word16 = 557 +primOpTag CasAddrOp_Word32 = 558 +primOpTag CasAddrOp_Word64 = 559 +primOpTag FetchAddAddrOp_Word = 560 +primOpTag FetchSubAddrOp_Word = 561 +primOpTag FetchAndAddrOp_Word = 562 +primOpTag FetchNandAddrOp_Word = 563 +primOpTag FetchOrAddrOp_Word = 564 +primOpTag FetchXorAddrOp_Word = 565 +primOpTag AtomicReadAddrOp_Word = 566 +primOpTag AtomicWriteAddrOp_Word = 567 +primOpTag NewMutVarOp = 568 +primOpTag ReadMutVarOp = 569 +primOpTag WriteMutVarOp = 570 +primOpTag AtomicSwapMutVarOp = 571 +primOpTag AtomicModifyMutVar2Op = 572 +primOpTag AtomicModifyMutVar_Op = 573 +primOpTag CasMutVarOp = 574 +primOpTag CatchOp = 575 +primOpTag RaiseOp = 576 +primOpTag RaiseUnderflowOp = 577 +primOpTag RaiseOverflowOp = 578 +primOpTag RaiseDivZeroOp = 579 +primOpTag RaiseIOOp = 580 +primOpTag MaskAsyncExceptionsOp = 581 +primOpTag MaskUninterruptibleOp = 582 +primOpTag UnmaskAsyncExceptionsOp = 583 +primOpTag MaskStatus = 584 +primOpTag NewPromptTagOp = 585 +primOpTag PromptOp = 586 +primOpTag Control0Op = 587 +primOpTag AtomicallyOp = 588 +primOpTag RetryOp = 589 +primOpTag CatchRetryOp = 590 +primOpTag CatchSTMOp = 591 +primOpTag NewTVarOp = 592 +primOpTag ReadTVarOp = 593 +primOpTag ReadTVarIOOp = 594 +primOpTag WriteTVarOp = 595 +primOpTag NewMVarOp = 596 +primOpTag TakeMVarOp = 597 +primOpTag TryTakeMVarOp = 598 +primOpTag PutMVarOp = 599 +primOpTag TryPutMVarOp = 600 +primOpTag ReadMVarOp = 601 +primOpTag TryReadMVarOp = 602 +primOpTag IsEmptyMVarOp = 603 +primOpTag NewIOPortOp = 604 +primOpTag ReadIOPortOp = 605 +primOpTag WriteIOPortOp = 606 +primOpTag DelayOp = 607 +primOpTag WaitReadOp = 608 +primOpTag WaitWriteOp = 609 +primOpTag ForkOp = 610 +primOpTag ForkOnOp = 611 +primOpTag KillThreadOp = 612 +primOpTag YieldOp = 613 +primOpTag MyThreadIdOp = 614 +primOpTag LabelThreadOp = 615 +primOpTag IsCurrentThreadBoundOp = 616 +primOpTag NoDuplicateOp = 617 +primOpTag GetThreadLabelOp = 618 +primOpTag ThreadStatusOp = 619 +primOpTag ListThreadsOp = 620 +primOpTag MkWeakOp = 621 +primOpTag MkWeakNoFinalizerOp = 622 +primOpTag AddCFinalizerToWeakOp = 623 +primOpTag DeRefWeakOp = 624 +primOpTag FinalizeWeakOp = 625 +primOpTag TouchOp = 626 +primOpTag MakeStablePtrOp = 627 +primOpTag DeRefStablePtrOp = 628 +primOpTag EqStablePtrOp = 629 +primOpTag MakeStableNameOp = 630 +primOpTag StableNameToIntOp = 631 +primOpTag CompactNewOp = 632 +primOpTag CompactResizeOp = 633 +primOpTag CompactContainsOp = 634 +primOpTag CompactContainsAnyOp = 635 +primOpTag CompactGetFirstBlockOp = 636 +primOpTag CompactGetNextBlockOp = 637 +primOpTag CompactAllocateBlockOp = 638 +primOpTag CompactFixupPointersOp = 639 +primOpTag CompactAdd = 640 +primOpTag CompactAddWithSharing = 641 +primOpTag CompactSize = 642 +primOpTag ReallyUnsafePtrEqualityOp = 643 +primOpTag ParOp = 644 +primOpTag SparkOp = 645 +primOpTag SeqOp = 646 +primOpTag GetSparkOp = 647 +primOpTag NumSparks = 648 +primOpTag KeepAliveOp = 649 +primOpTag DataToTagOp = 650 +primOpTag TagToEnumOp = 651 +primOpTag AddrToAnyOp = 652 +primOpTag AnyToAddrOp = 653 +primOpTag MkApUpd0_Op = 654 +primOpTag NewBCOOp = 655 +primOpTag UnpackClosureOp = 656 +primOpTag ClosureSizeOp = 657 +primOpTag GetApStackValOp = 658 +primOpTag GetCCSOfOp = 659 +primOpTag GetCurrentCCSOp = 660 +primOpTag ClearCCSOp = 661 +primOpTag WhereFromOp = 662 +primOpTag TraceEventOp = 663 +primOpTag TraceEventBinaryOp = 664 +primOpTag TraceMarkerOp = 665 +primOpTag SetThreadAllocationCounter = 666 +primOpTag (VecBroadcastOp IntVec 16 W8) = 667 +primOpTag (VecBroadcastOp IntVec 8 W16) = 668 +primOpTag (VecBroadcastOp IntVec 4 W32) = 669 +primOpTag (VecBroadcastOp IntVec 2 W64) = 670 +primOpTag (VecBroadcastOp IntVec 32 W8) = 671 +primOpTag (VecBroadcastOp IntVec 16 W16) = 672 +primOpTag (VecBroadcastOp IntVec 8 W32) = 673 +primOpTag (VecBroadcastOp IntVec 4 W64) = 674 +primOpTag (VecBroadcastOp IntVec 64 W8) = 675 +primOpTag (VecBroadcastOp IntVec 32 W16) = 676 +primOpTag (VecBroadcastOp IntVec 16 W32) = 677 +primOpTag (VecBroadcastOp IntVec 8 W64) = 678 +primOpTag (VecBroadcastOp WordVec 16 W8) = 679 +primOpTag (VecBroadcastOp WordVec 8 W16) = 680 +primOpTag (VecBroadcastOp WordVec 4 W32) = 681 +primOpTag (VecBroadcastOp WordVec 2 W64) = 682 +primOpTag (VecBroadcastOp WordVec 32 W8) = 683 +primOpTag (VecBroadcastOp WordVec 16 W16) = 684 +primOpTag (VecBroadcastOp WordVec 8 W32) = 685 +primOpTag (VecBroadcastOp WordVec 4 W64) = 686 +primOpTag (VecBroadcastOp WordVec 64 W8) = 687 +primOpTag (VecBroadcastOp WordVec 32 W16) = 688 +primOpTag (VecBroadcastOp WordVec 16 W32) = 689 +primOpTag (VecBroadcastOp WordVec 8 W64) = 690 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 691 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 692 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 693 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 694 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 695 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 696 +primOpTag (VecPackOp IntVec 16 W8) = 697 +primOpTag (VecPackOp IntVec 8 W16) = 698 +primOpTag (VecPackOp IntVec 4 W32) = 699 +primOpTag (VecPackOp IntVec 2 W64) = 700 +primOpTag (VecPackOp IntVec 32 W8) = 701 +primOpTag (VecPackOp IntVec 16 W16) = 702 +primOpTag (VecPackOp IntVec 8 W32) = 703 +primOpTag (VecPackOp IntVec 4 W64) = 704 +primOpTag (VecPackOp IntVec 64 W8) = 705 +primOpTag (VecPackOp IntVec 32 W16) = 706 +primOpTag (VecPackOp IntVec 16 W32) = 707 +primOpTag (VecPackOp IntVec 8 W64) = 708 +primOpTag (VecPackOp WordVec 16 W8) = 709 +primOpTag (VecPackOp WordVec 8 W16) = 710 +primOpTag (VecPackOp WordVec 4 W32) = 711 +primOpTag (VecPackOp WordVec 2 W64) = 712 +primOpTag (VecPackOp WordVec 32 W8) = 713 +primOpTag (VecPackOp WordVec 16 W16) = 714 +primOpTag (VecPackOp WordVec 8 W32) = 715 +primOpTag (VecPackOp WordVec 4 W64) = 716 +primOpTag (VecPackOp WordVec 64 W8) = 717 +primOpTag (VecPackOp WordVec 32 W16) = 718 +primOpTag (VecPackOp WordVec 16 W32) = 719 +primOpTag (VecPackOp WordVec 8 W64) = 720 +primOpTag (VecPackOp FloatVec 4 W32) = 721 +primOpTag (VecPackOp FloatVec 2 W64) = 722 +primOpTag (VecPackOp FloatVec 8 W32) = 723 +primOpTag (VecPackOp FloatVec 4 W64) = 724 +primOpTag (VecPackOp FloatVec 16 W32) = 725 +primOpTag (VecPackOp FloatVec 8 W64) = 726 +primOpTag (VecUnpackOp IntVec 16 W8) = 727 +primOpTag (VecUnpackOp IntVec 8 W16) = 728 +primOpTag (VecUnpackOp IntVec 4 W32) = 729 +primOpTag (VecUnpackOp IntVec 2 W64) = 730 +primOpTag (VecUnpackOp IntVec 32 W8) = 731 +primOpTag (VecUnpackOp IntVec 16 W16) = 732 +primOpTag (VecUnpackOp IntVec 8 W32) = 733 +primOpTag (VecUnpackOp IntVec 4 W64) = 734 +primOpTag (VecUnpackOp IntVec 64 W8) = 735 +primOpTag (VecUnpackOp IntVec 32 W16) = 736 +primOpTag (VecUnpackOp IntVec 16 W32) = 737 +primOpTag (VecUnpackOp IntVec 8 W64) = 738 +primOpTag (VecUnpackOp WordVec 16 W8) = 739 +primOpTag (VecUnpackOp WordVec 8 W16) = 740 +primOpTag (VecUnpackOp WordVec 4 W32) = 741 +primOpTag (VecUnpackOp WordVec 2 W64) = 742 +primOpTag (VecUnpackOp WordVec 32 W8) = 743 +primOpTag (VecUnpackOp WordVec 16 W16) = 744 +primOpTag (VecUnpackOp WordVec 8 W32) = 745 +primOpTag (VecUnpackOp WordVec 4 W64) = 746 +primOpTag (VecUnpackOp WordVec 64 W8) = 747 +primOpTag (VecUnpackOp WordVec 32 W16) = 748 +primOpTag (VecUnpackOp WordVec 16 W32) = 749 +primOpTag (VecUnpackOp WordVec 8 W64) = 750 +primOpTag (VecUnpackOp FloatVec 4 W32) = 751 +primOpTag (VecUnpackOp FloatVec 2 W64) = 752 +primOpTag (VecUnpackOp FloatVec 8 W32) = 753 +primOpTag (VecUnpackOp FloatVec 4 W64) = 754 +primOpTag (VecUnpackOp FloatVec 16 W32) = 755 +primOpTag (VecUnpackOp FloatVec 8 W64) = 756 +primOpTag (VecInsertOp IntVec 16 W8) = 757 +primOpTag (VecInsertOp IntVec 8 W16) = 758 +primOpTag (VecInsertOp IntVec 4 W32) = 759 +primOpTag (VecInsertOp IntVec 2 W64) = 760 +primOpTag (VecInsertOp IntVec 32 W8) = 761 +primOpTag (VecInsertOp IntVec 16 W16) = 762 +primOpTag (VecInsertOp IntVec 8 W32) = 763 +primOpTag (VecInsertOp IntVec 4 W64) = 764 +primOpTag (VecInsertOp IntVec 64 W8) = 765 +primOpTag (VecInsertOp IntVec 32 W16) = 766 +primOpTag (VecInsertOp IntVec 16 W32) = 767 +primOpTag (VecInsertOp IntVec 8 W64) = 768 +primOpTag (VecInsertOp WordVec 16 W8) = 769 +primOpTag (VecInsertOp WordVec 8 W16) = 770 +primOpTag (VecInsertOp WordVec 4 W32) = 771 +primOpTag (VecInsertOp WordVec 2 W64) = 772 +primOpTag (VecInsertOp WordVec 32 W8) = 773 +primOpTag (VecInsertOp WordVec 16 W16) = 774 +primOpTag (VecInsertOp WordVec 8 W32) = 775 +primOpTag (VecInsertOp WordVec 4 W64) = 776 +primOpTag (VecInsertOp WordVec 64 W8) = 777 +primOpTag (VecInsertOp WordVec 32 W16) = 778 +primOpTag (VecInsertOp WordVec 16 W32) = 779 +primOpTag (VecInsertOp WordVec 8 W64) = 780 +primOpTag (VecInsertOp FloatVec 4 W32) = 781 +primOpTag (VecInsertOp FloatVec 2 W64) = 782 +primOpTag (VecInsertOp FloatVec 8 W32) = 783 +primOpTag (VecInsertOp FloatVec 4 W64) = 784 +primOpTag (VecInsertOp FloatVec 16 W32) = 785 +primOpTag (VecInsertOp FloatVec 8 W64) = 786 +primOpTag (VecAddOp IntVec 16 W8) = 787 +primOpTag (VecAddOp IntVec 8 W16) = 788 +primOpTag (VecAddOp IntVec 4 W32) = 789 +primOpTag (VecAddOp IntVec 2 W64) = 790 +primOpTag (VecAddOp IntVec 32 W8) = 791 +primOpTag (VecAddOp IntVec 16 W16) = 792 +primOpTag (VecAddOp IntVec 8 W32) = 793 +primOpTag (VecAddOp IntVec 4 W64) = 794 +primOpTag (VecAddOp IntVec 64 W8) = 795 +primOpTag (VecAddOp IntVec 32 W16) = 796 +primOpTag (VecAddOp IntVec 16 W32) = 797 +primOpTag (VecAddOp IntVec 8 W64) = 798 +primOpTag (VecAddOp WordVec 16 W8) = 799 +primOpTag (VecAddOp WordVec 8 W16) = 800 +primOpTag (VecAddOp WordVec 4 W32) = 801 +primOpTag (VecAddOp WordVec 2 W64) = 802 +primOpTag (VecAddOp WordVec 32 W8) = 803 +primOpTag (VecAddOp WordVec 16 W16) = 804 +primOpTag (VecAddOp WordVec 8 W32) = 805 +primOpTag (VecAddOp WordVec 4 W64) = 806 +primOpTag (VecAddOp WordVec 64 W8) = 807 +primOpTag (VecAddOp WordVec 32 W16) = 808 +primOpTag (VecAddOp WordVec 16 W32) = 809 +primOpTag (VecAddOp WordVec 8 W64) = 810 +primOpTag (VecAddOp FloatVec 4 W32) = 811 +primOpTag (VecAddOp FloatVec 2 W64) = 812 +primOpTag (VecAddOp FloatVec 8 W32) = 813 +primOpTag (VecAddOp FloatVec 4 W64) = 814 +primOpTag (VecAddOp FloatVec 16 W32) = 815 +primOpTag (VecAddOp FloatVec 8 W64) = 816 +primOpTag (VecSubOp IntVec 16 W8) = 817 +primOpTag (VecSubOp IntVec 8 W16) = 818 +primOpTag (VecSubOp IntVec 4 W32) = 819 +primOpTag (VecSubOp IntVec 2 W64) = 820 +primOpTag (VecSubOp IntVec 32 W8) = 821 +primOpTag (VecSubOp IntVec 16 W16) = 822 +primOpTag (VecSubOp IntVec 8 W32) = 823 +primOpTag (VecSubOp IntVec 4 W64) = 824 +primOpTag (VecSubOp IntVec 64 W8) = 825 +primOpTag (VecSubOp IntVec 32 W16) = 826 +primOpTag (VecSubOp IntVec 16 W32) = 827 +primOpTag (VecSubOp IntVec 8 W64) = 828 +primOpTag (VecSubOp WordVec 16 W8) = 829 +primOpTag (VecSubOp WordVec 8 W16) = 830 +primOpTag (VecSubOp WordVec 4 W32) = 831 +primOpTag (VecSubOp WordVec 2 W64) = 832 +primOpTag (VecSubOp WordVec 32 W8) = 833 +primOpTag (VecSubOp WordVec 16 W16) = 834 +primOpTag (VecSubOp WordVec 8 W32) = 835 +primOpTag (VecSubOp WordVec 4 W64) = 836 +primOpTag (VecSubOp WordVec 64 W8) = 837 +primOpTag (VecSubOp WordVec 32 W16) = 838 +primOpTag (VecSubOp WordVec 16 W32) = 839 +primOpTag (VecSubOp WordVec 8 W64) = 840 +primOpTag (VecSubOp FloatVec 4 W32) = 841 +primOpTag (VecSubOp FloatVec 2 W64) = 842 +primOpTag (VecSubOp FloatVec 8 W32) = 843 +primOpTag (VecSubOp FloatVec 4 W64) = 844 +primOpTag (VecSubOp FloatVec 16 W32) = 845 +primOpTag (VecSubOp FloatVec 8 W64) = 846 +primOpTag (VecMulOp IntVec 16 W8) = 847 +primOpTag (VecMulOp IntVec 8 W16) = 848 +primOpTag (VecMulOp IntVec 4 W32) = 849 +primOpTag (VecMulOp IntVec 2 W64) = 850 +primOpTag (VecMulOp IntVec 32 W8) = 851 +primOpTag (VecMulOp IntVec 16 W16) = 852 +primOpTag (VecMulOp IntVec 8 W32) = 853 +primOpTag (VecMulOp IntVec 4 W64) = 854 +primOpTag (VecMulOp IntVec 64 W8) = 855 +primOpTag (VecMulOp IntVec 32 W16) = 856 +primOpTag (VecMulOp IntVec 16 W32) = 857 +primOpTag (VecMulOp IntVec 8 W64) = 858 +primOpTag (VecMulOp WordVec 16 W8) = 859 +primOpTag (VecMulOp WordVec 8 W16) = 860 +primOpTag (VecMulOp WordVec 4 W32) = 861 +primOpTag (VecMulOp WordVec 2 W64) = 862 +primOpTag (VecMulOp WordVec 32 W8) = 863 +primOpTag (VecMulOp WordVec 16 W16) = 864 +primOpTag (VecMulOp WordVec 8 W32) = 865 +primOpTag (VecMulOp WordVec 4 W64) = 866 +primOpTag (VecMulOp WordVec 64 W8) = 867 +primOpTag (VecMulOp WordVec 32 W16) = 868 +primOpTag (VecMulOp WordVec 16 W32) = 869 +primOpTag (VecMulOp WordVec 8 W64) = 870 +primOpTag (VecMulOp FloatVec 4 W32) = 871 +primOpTag (VecMulOp FloatVec 2 W64) = 872 +primOpTag (VecMulOp FloatVec 8 W32) = 873 +primOpTag (VecMulOp FloatVec 4 W64) = 874 +primOpTag (VecMulOp FloatVec 16 W32) = 875 +primOpTag (VecMulOp FloatVec 8 W64) = 876 +primOpTag (VecDivOp FloatVec 4 W32) = 877 +primOpTag (VecDivOp FloatVec 2 W64) = 878 +primOpTag (VecDivOp FloatVec 8 W32) = 879 +primOpTag (VecDivOp FloatVec 4 W64) = 880 +primOpTag (VecDivOp FloatVec 16 W32) = 881 +primOpTag (VecDivOp FloatVec 8 W64) = 882 +primOpTag (VecQuotOp IntVec 16 W8) = 883 +primOpTag (VecQuotOp IntVec 8 W16) = 884 +primOpTag (VecQuotOp IntVec 4 W32) = 885 +primOpTag (VecQuotOp IntVec 2 W64) = 886 +primOpTag (VecQuotOp IntVec 32 W8) = 887 +primOpTag (VecQuotOp IntVec 16 W16) = 888 +primOpTag (VecQuotOp IntVec 8 W32) = 889 +primOpTag (VecQuotOp IntVec 4 W64) = 890 +primOpTag (VecQuotOp IntVec 64 W8) = 891 +primOpTag (VecQuotOp IntVec 32 W16) = 892 +primOpTag (VecQuotOp IntVec 16 W32) = 893 +primOpTag (VecQuotOp IntVec 8 W64) = 894 +primOpTag (VecQuotOp WordVec 16 W8) = 895 +primOpTag (VecQuotOp WordVec 8 W16) = 896 +primOpTag (VecQuotOp WordVec 4 W32) = 897 +primOpTag (VecQuotOp WordVec 2 W64) = 898 +primOpTag (VecQuotOp WordVec 32 W8) = 899 +primOpTag (VecQuotOp WordVec 16 W16) = 900 +primOpTag (VecQuotOp WordVec 8 W32) = 901 +primOpTag (VecQuotOp WordVec 4 W64) = 902 +primOpTag (VecQuotOp WordVec 64 W8) = 903 +primOpTag (VecQuotOp WordVec 32 W16) = 904 +primOpTag (VecQuotOp WordVec 16 W32) = 905 +primOpTag (VecQuotOp WordVec 8 W64) = 906 +primOpTag (VecRemOp IntVec 16 W8) = 907 +primOpTag (VecRemOp IntVec 8 W16) = 908 +primOpTag (VecRemOp IntVec 4 W32) = 909 +primOpTag (VecRemOp IntVec 2 W64) = 910 +primOpTag (VecRemOp IntVec 32 W8) = 911 +primOpTag (VecRemOp IntVec 16 W16) = 912 +primOpTag (VecRemOp IntVec 8 W32) = 913 +primOpTag (VecRemOp IntVec 4 W64) = 914 +primOpTag (VecRemOp IntVec 64 W8) = 915 +primOpTag (VecRemOp IntVec 32 W16) = 916 +primOpTag (VecRemOp IntVec 16 W32) = 917 +primOpTag (VecRemOp IntVec 8 W64) = 918 +primOpTag (VecRemOp WordVec 16 W8) = 919 +primOpTag (VecRemOp WordVec 8 W16) = 920 +primOpTag (VecRemOp WordVec 4 W32) = 921 +primOpTag (VecRemOp WordVec 2 W64) = 922 +primOpTag (VecRemOp WordVec 32 W8) = 923 +primOpTag (VecRemOp WordVec 16 W16) = 924 +primOpTag (VecRemOp WordVec 8 W32) = 925 +primOpTag (VecRemOp WordVec 4 W64) = 926 +primOpTag (VecRemOp WordVec 64 W8) = 927 +primOpTag (VecRemOp WordVec 32 W16) = 928 +primOpTag (VecRemOp WordVec 16 W32) = 929 +primOpTag (VecRemOp WordVec 8 W64) = 930 +primOpTag (VecNegOp IntVec 16 W8) = 931 +primOpTag (VecNegOp IntVec 8 W16) = 932 +primOpTag (VecNegOp IntVec 4 W32) = 933 +primOpTag (VecNegOp IntVec 2 W64) = 934 +primOpTag (VecNegOp IntVec 32 W8) = 935 +primOpTag (VecNegOp IntVec 16 W16) = 936 +primOpTag (VecNegOp IntVec 8 W32) = 937 +primOpTag (VecNegOp IntVec 4 W64) = 938 +primOpTag (VecNegOp IntVec 64 W8) = 939 +primOpTag (VecNegOp IntVec 32 W16) = 940 +primOpTag (VecNegOp IntVec 16 W32) = 941 +primOpTag (VecNegOp IntVec 8 W64) = 942 +primOpTag (VecNegOp FloatVec 4 W32) = 943 +primOpTag (VecNegOp FloatVec 2 W64) = 944 +primOpTag (VecNegOp FloatVec 8 W32) = 945 +primOpTag (VecNegOp FloatVec 4 W64) = 946 +primOpTag (VecNegOp FloatVec 16 W32) = 947 +primOpTag (VecNegOp FloatVec 8 W64) = 948 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 949 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 950 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 951 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 952 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 953 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 954 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 955 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 956 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 957 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 958 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 959 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 960 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 961 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 962 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 963 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 964 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 965 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 966 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 967 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 968 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 969 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 970 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 971 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 972 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 973 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 974 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 975 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 976 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 977 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 978 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 979 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 980 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 981 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 982 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 983 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 984 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 985 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 986 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 987 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 988 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 989 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 990 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 991 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 992 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 993 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 994 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 995 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 996 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 997 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 998 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 999 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1000 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1001 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1002 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1003 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1004 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1005 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1006 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1007 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1008 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1009 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1010 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1011 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1012 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1013 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1014 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1015 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1016 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1017 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1018 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1019 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1020 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1021 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1022 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1023 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1024 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1025 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1026 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1027 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1028 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1029 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1030 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1031 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1032 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1033 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1034 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1035 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1036 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1037 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1038 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1039 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1040 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1041 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1042 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1043 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1044 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1045 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1046 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1047 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1048 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1049 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1050 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1051 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1052 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1053 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1054 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1055 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1056 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1057 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1058 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1059 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1060 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1061 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1062 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1063 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1064 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1065 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1066 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1067 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1068 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1069 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1070 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1071 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1072 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1073 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1074 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1075 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1076 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1077 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1078 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1079 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1080 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1081 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1082 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1083 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1084 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1085 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1086 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1087 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1088 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1089 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1090 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1091 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1092 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1093 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1094 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1095 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1096 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1097 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1098 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1099 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1100 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1101 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1102 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1103 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1104 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1105 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1106 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1107 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1108 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1109 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1110 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1111 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1112 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1113 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1114 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1115 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1116 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1117 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1118 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1119 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1120 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1121 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1122 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1123 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1124 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1125 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1126 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1127 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1128 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1129 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1130 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1131 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1132 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1133 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1134 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1135 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1136 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1137 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1138 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1139 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1140 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1141 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1142 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1143 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1144 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1145 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1146 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1147 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1148 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1149 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1150 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1151 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1152 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1153 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1154 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1155 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1156 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1157 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1158 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1159 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1160 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1161 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1162 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1163 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1164 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1165 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1166 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1167 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1168 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1169 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1170 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1171 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1172 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1173 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1174 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1175 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1176 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1177 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1178 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1179 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1180 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1181 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1182 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1183 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1184 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1185 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1186 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1187 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1188 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1189 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1190 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1191 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1192 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1193 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1194 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1195 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1196 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1197 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1198 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1199 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1200 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1201 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1202 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1203 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1204 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1205 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1206 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1207 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1208 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1209 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1210 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1211 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1212 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1213 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1214 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1215 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1216 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1217 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1218 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1219 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1220 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1221 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1222 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1223 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1224 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1225 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1226 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1227 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1228 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1229 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1230 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1231 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1232 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1233 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1234 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1235 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1236 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1237 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1238 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1239 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1240 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1241 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1242 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1243 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1244 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1245 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1246 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1247 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1248 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1249 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1250 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1251 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1252 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1253 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1254 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1255 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1256 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1257 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1258 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1259 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1260 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1261 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1262 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1263 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1264 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1265 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1266 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1267 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1268 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1269 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1270 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1271 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1272 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1273 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1274 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1275 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1276 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1277 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1278 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1279 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1280 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1281 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1282 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1283 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1284 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1285 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1286 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1287 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1288 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1289 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1290 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1291 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1292 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1293 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1294 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1295 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1296 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1297 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1298 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1299 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1300 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1301 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1302 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1303 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1304 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1305 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1306 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1307 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1308 +primOpTag PrefetchByteArrayOp3 = 1309 +primOpTag PrefetchMutableByteArrayOp3 = 1310 +primOpTag PrefetchAddrOp3 = 1311 +primOpTag PrefetchValueOp3 = 1312 +primOpTag PrefetchByteArrayOp2 = 1313 +primOpTag PrefetchMutableByteArrayOp2 = 1314 +primOpTag PrefetchAddrOp2 = 1315 +primOpTag PrefetchValueOp2 = 1316 +primOpTag PrefetchByteArrayOp1 = 1317 +primOpTag PrefetchMutableByteArrayOp1 = 1318 +primOpTag PrefetchAddrOp1 = 1319 +primOpTag PrefetchValueOp1 = 1320 +primOpTag PrefetchByteArrayOp0 = 1321 +primOpTag PrefetchMutableByteArrayOp0 = 1322 +primOpTag PrefetchAddrOp0 = 1323 +primOpTag PrefetchValueOp0 = 1324 diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -1,18 +1,17 @@ -[("GCC extra via C opts", "") -,("C compiler command", "/usr/local/opt/ccache/libexec/gcc") -,("C compiler flags", "--target=x86_64-apple-darwin ") -,("C++ compiler command", "/usr/local/opt/ccache/libexec/g++") +[("C compiler command", "/usr/bin/gcc") +,("C compiler flags", "--target=x86_64-apple-darwin -Qunused-arguments") +,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ") -,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") +,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains") ,("C compiler supports -no-pie", "NO") -,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc") +,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") ,("ld command", "ld") ,("ld flags", "") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES") +,("ld supports response files", "NO") ,("ld is GNU ld", "NO") -,("ld supports single module", "NO") ,("Merge objects command", "ld") ,("Merge objects flags", "-r") ,("ar command", "/usr/bin/ar") @@ -35,7 +34,6 @@ ,("target has GNU nonexec stack", "NO") ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES") -,("target has RTS linker", "YES") ,("target has libm", "YES") ,("Unregisterised", "NO") ,("LLVM target", "x86_64-apple-darwin") diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h --- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +++ b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -1,12 +1,5 @@ /* This file is created automatically. Do not edit by hand.*/ -// MAX_Real_Vanilla_REG 6 -// MAX_Real_Float_REG 6 -// MAX_Real_Double_REG 6 -// MAX_Real_Long_REG 0 -// WORD_SIZE 8 -// BITMAP_BITS_SHIFT 6 -// TAG_BITS 3 #define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,104,120,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h --- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h +++ b/ghc-lib/stage0/rts/build/include/ghcautoconf.h @@ -106,36 +106,36 @@ /* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 -/* Define to 1 if you have the 'clock_gettime' function. */ +/* Define to 1 if you have the `clock_gettime' function. */ #define HAVE_CLOCK_GETTIME 1 -/* Define to 1 if you have the 'ctime_r' function. */ +/* Define to 1 if you have the `ctime_r' function. */ #define HAVE_CTIME_R 1 /* Define to 1 if you have the header file. */ #define HAVE_CTYPE_H 1 -/* Define to 1 if you have the declaration of 'ctime_r', and to 0 if you +/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you don't. */ #define HAVE_DECL_CTIME_R 1 -/* Define to 1 if you have the declaration of 'environ', and to 0 if you +/* Define to 1 if you have the declaration of `environ', and to 0 if you don't. */ #define HAVE_DECL_ENVIRON 0 -/* Define to 1 if you have the declaration of 'MADV_DONTNEED', and to 0 if you +/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */ -/* Define to 1 if you have the declaration of 'MADV_FREE', and to 0 if you +/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_FREE */ -/* Define to 1 if you have the declaration of 'MAP_NORESERVE', and to 0 if you +/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you don't. */ /* #undef HAVE_DECL_MAP_NORESERVE */ -/* Define to 1 if you have the declaration of 'program_invocation_short_name', +/* Define to 1 if you have the declaration of `program_invocation_short_name', and to 0 if you don't. */ #define HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME 0 @@ -145,7 +145,7 @@ /* Define to 1 if you have the header file. */ #define HAVE_DLFCN_H 1 -/* Define to 1 if you have the 'dlinfo' function. */ +/* Define to 1 if you have the `dlinfo' function. */ /* #undef HAVE_DLINFO */ /* Define to 1 if you have the header file. */ @@ -154,7 +154,7 @@ /* Define to 1 if you have the header file. */ #define HAVE_ERRNO_H 1 -/* Define to 1 if you have the 'eventfd' function. */ +/* Define to 1 if you have the `eventfd' function. */ /* #undef HAVE_EVENTFD */ /* Define to 1 if you have the header file. */ @@ -163,25 +163,25 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_FFI_H */ -/* Define to 1 if you have the 'fork' function. */ +/* Define to 1 if you have the `fork' function. */ #define HAVE_FORK 1 -/* Define to 1 if you have the 'getclock' function. */ +/* Define to 1 if you have the `getclock' function. */ /* #undef HAVE_GETCLOCK */ /* Define to 1 if you have the `GetModuleFileName' function. */ /* #undef HAVE_GETMODULEFILENAME */ -/* Define to 1 if you have the 'getpid' function. */ +/* Define to 1 if you have the `getpid' function. */ #define HAVE_GETPID 1 -/* Define to 1 if you have the 'getrusage' function. */ +/* Define to 1 if you have the `getrusage' function. */ #define HAVE_GETRUSAGE 1 -/* Define to 1 if you have the 'gettimeofday' function. */ +/* Define to 1 if you have the `gettimeofday' function. */ #define HAVE_GETTIMEOFDAY 1 -/* Define to 1 if you have the 'getuid' function. */ +/* Define to 1 if you have the `getuid' function. */ #define HAVE_GETUID 1 /* Define to 1 if you have the header file. */ @@ -190,37 +190,41 @@ /* Define to 1 if you have the header file. */ #define HAVE_INTTYPES_H 1 -/* Define to 1 if you have the 'bfd' library (-lbfd). */ +/* Define to 1 if you have the `bfd' library (-lbfd). */ /* #undef HAVE_LIBBFD */ -/* Define to 1 if you have the 'dl' library (-ldl). */ +/* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 -/* Define to 1 if you have the 'iberty' library (-liberty). */ +/* Define to 1 if you have the `iberty' library (-liberty). */ /* #undef HAVE_LIBIBERTY */ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 -/* Define to 1 if you have the 'mingwex' library (-lmingwex). */ +/* Define to 1 if you have the `mingwex' library (-lmingwex). */ /* #undef HAVE_LIBMINGWEX */ /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 -/* Define to 1 if you have the 'pthread' library (-lpthread). */ +/* Define to 1 if you have the `pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 -/* Define to 1 if you have the 'rt' library (-lrt). */ +/* Define to 1 if you have the `rt' library (-lrt). */ /* #undef HAVE_LIBRT */ +/* Define to 1 if you wish to compress IPE data in compiler results (requires + libzstd) */ +#define HAVE_LIBZSTD 0 + /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_LOCALE_H 1 -/* Define to 1 if the system has the type 'long long'. */ +/* Define to 1 if the system has the type `long long'. */ #define HAVE_LONG_LONG 1 /* Define to 1 if you have the header file. */ @@ -238,7 +242,7 @@ /* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */ #define HAVE_PRINTF_LDBLSTUB 0 -/* Define to 1 if you have the 'pthread_condattr_setclock' function. */ +/* Define to 1 if you have the `pthread_condattr_setclock' function. */ /* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */ /* Define to 1 if you have the header file. */ @@ -262,25 +266,25 @@ /* Define to 1 if you have the header file. */ #define HAVE_PWD_H 1 -/* Define to 1 if you have the 'raise' function. */ +/* Define to 1 if you have the `raise' function. */ #define HAVE_RAISE 1 -/* Define to 1 if you have the 'sched_getaffinity' function. */ +/* 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 -/* Define to 1 if you have the 'sched_setaffinity' function. */ +/* Define to 1 if you have the `sched_setaffinity' function. */ /* #undef HAVE_SCHED_SETAFFINITY */ -/* Define to 1 if you have the 'setitimer' function. */ +/* Define to 1 if you have the `setitimer' function. */ #define HAVE_SETITIMER 1 -/* Define to 1 if you have the 'setlocale' function. */ +/* Define to 1 if you have the `setlocale' function. */ #define HAVE_SETLOCALE 1 -/* Define to 1 if you have the 'siginterrupt' function. */ +/* Define to 1 if you have the `siginterrupt' function. */ #define HAVE_SIGINTERRUPT 1 /* Define to 1 if you have the header file. */ @@ -304,7 +308,7 @@ /* Define to 1 if Apple-style dead-stripping is supported. */ #define HAVE_SUBSECTIONS_VIA_SYMBOLS 1 -/* Define to 1 if you have the 'sysconf' function. */ +/* Define to 1 if you have the `sysconf' function. */ #define HAVE_SYSCONF 1 /* Define to 1 if you have libffi. */ @@ -358,22 +362,22 @@ /* Define to 1 if you have the header file. */ #define HAVE_TERMIOS_H 1 -/* Define to 1 if you have the 'timer_settime' function. */ +/* Define to 1 if you have the `timer_settime' function. */ /* #undef HAVE_TIMER_SETTIME */ -/* Define to 1 if you have the 'times' function. */ +/* Define to 1 if you have the `times' function. */ #define HAVE_TIMES 1 /* Define to 1 if you have the header file. */ #define HAVE_UNISTD_H 1 -/* Define to 1 if you have the 'uselocale' function. */ +/* Define to 1 if you have the `uselocale' function. */ #define HAVE_USELOCALE 1 /* Define to 1 if you have the header file. */ #define HAVE_UTIME_H 1 -/* Define to 1 if you have the 'vfork' function. */ +/* Define to 1 if you have the `vfork' function. */ #define HAVE_VFORK 1 /* Define to 1 if you have the header file. */ @@ -391,12 +395,15 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_WINSOCK_H */ -/* Define to 1 if 'fork' works. */ +/* Define to 1 if `fork' works. */ #define HAVE_WORKING_FORK 1 -/* Define to 1 if 'vfork' works. */ +/* Define to 1 if `vfork' works. */ #define HAVE_WORKING_VFORK 1 +/* Define to 1 if you have the header file. */ +/* #undef HAVE_ZSTD_H */ + /* Define to 1 if C symbols have a leading underscore added by the compiler. */ #define LEADING_UNDERSCORE 1 @@ -428,67 +435,67 @@ /* Use mmap in the runtime linker */ #define RTS_LINKER_USE_MMAP 1 -/* The size of 'char', as computed by sizeof. */ +/* The size of `char', as computed by sizeof. */ #define SIZEOF_CHAR 1 -/* The size of 'double', as computed by sizeof. */ +/* The size of `double', as computed by sizeof. */ #define SIZEOF_DOUBLE 8 -/* The size of 'float', as computed by sizeof. */ +/* The size of `float', as computed by sizeof. */ #define SIZEOF_FLOAT 4 -/* The size of 'int', as computed by sizeof. */ +/* The size of `int', as computed by sizeof. */ #define SIZEOF_INT 4 -/* The size of 'int16_t', as computed by sizeof. */ +/* The size of `int16_t', as computed by sizeof. */ #define SIZEOF_INT16_T 2 -/* The size of 'int32_t', as computed by sizeof. */ +/* The size of `int32_t', as computed by sizeof. */ #define SIZEOF_INT32_T 4 -/* The size of 'int64_t', as computed by sizeof. */ +/* The size of `int64_t', as computed by sizeof. */ #define SIZEOF_INT64_T 8 -/* The size of 'int8_t', as computed by sizeof. */ +/* The size of `int8_t', as computed by sizeof. */ #define SIZEOF_INT8_T 1 -/* The size of 'long', as computed by sizeof. */ +/* The size of `long', as computed by sizeof. */ #define SIZEOF_LONG 8 -/* The size of 'long long', as computed by sizeof. */ +/* The size of `long long', as computed by sizeof. */ #define SIZEOF_LONG_LONG 8 -/* The size of 'short', as computed by sizeof. */ +/* The size of `short', as computed by sizeof. */ #define SIZEOF_SHORT 2 -/* The size of 'uint16_t', as computed by sizeof. */ +/* The size of `uint16_t', as computed by sizeof. */ #define SIZEOF_UINT16_T 2 -/* The size of 'uint32_t', as computed by sizeof. */ +/* The size of `uint32_t', as computed by sizeof. */ #define SIZEOF_UINT32_T 4 -/* The size of 'uint64_t', as computed by sizeof. */ +/* The size of `uint64_t', as computed by sizeof. */ #define SIZEOF_UINT64_T 8 -/* The size of 'uint8_t', as computed by sizeof. */ +/* The size of `uint8_t', as computed by sizeof. */ #define SIZEOF_UINT8_T 1 -/* The size of 'unsigned char', as computed by sizeof. */ +/* The size of `unsigned char', as computed by sizeof. */ #define SIZEOF_UNSIGNED_CHAR 1 -/* The size of 'unsigned int', as computed by sizeof. */ +/* The size of `unsigned int', as computed by sizeof. */ #define SIZEOF_UNSIGNED_INT 4 -/* The size of 'unsigned long', as computed by sizeof. */ +/* The size of `unsigned long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG 8 -/* The size of 'unsigned long long', as computed by sizeof. */ +/* The size of `unsigned long long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG_LONG 8 -/* The size of 'unsigned short', as computed by sizeof. */ +/* The size of `unsigned short', as computed by sizeof. */ #define SIZEOF_UNSIGNED_SHORT 2 -/* The size of 'void *', as computed by sizeof. */ +/* The size of `void *', as computed by sizeof. */ #define SIZEOF_VOID_P 8 /* If using the C implementation of alloca, define if you know the @@ -499,7 +506,11 @@ STACK_DIRECTION = 0 => direction of growth unknown */ /* #undef STACK_DIRECTION */ -/* Define to 1 if all of the C89 standard headers exist (not just the ones +/* Define to 1 if you wish to statically link the libzstd compression library + in the compiler (requires libzstd) */ +#define STATIC_LIBZSTD 0 + +/* Define to 1 if all of the C90 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #define STDC_HEADERS 1 @@ -516,7 +527,7 @@ /* Set to 1 to use libdw */ #define USE_LIBDW 0 -/* Enable extensions on AIX, Interix, z/OS. */ +/* Enable extensions on AIX 3, Interix. */ #ifndef _ALL_SOURCE # define _ALL_SOURCE 1 #endif @@ -577,15 +588,11 @@ #ifndef __STDC_WANT_IEC_60559_DFP_EXT__ # define __STDC_WANT_IEC_60559_DFP_EXT__ 1 #endif -/* Enable extensions specified by C23 Annex F. */ -#ifndef __STDC_WANT_IEC_60559_EXT__ -# define __STDC_WANT_IEC_60559_EXT__ 1 -#endif /* Enable extensions specified by ISO/IEC TS 18661-4:2015. */ #ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__ # define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1 #endif -/* Enable extensions specified by C23 Annex H and ISO/IEC TS 18661-3:2015. */ +/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */ #ifndef __STDC_WANT_IEC_60559_TYPES_EXT__ # define __STDC_WANT_IEC_60559_TYPES_EXT__ 1 #endif @@ -626,22 +633,16 @@ /* Number of bits in a file offset, on hosts where this is settable. */ /* #undef _FILE_OFFSET_BITS */ -/* Define to 1 on platforms where this makes off_t a 64-bit type. */ +/* Define for large files, on AIX-style hosts. */ /* #undef _LARGE_FILES */ -/* Number of bits in time_t, on hosts where this is settable. */ -/* #undef _TIME_BITS */ - -/* Define to 1 on platforms where this makes time_t a 64-bit type. */ -/* #undef __MINGW_USE_VC2005_COMPAT */ - /* ARM pre v6 */ /* #undef arm_HOST_ARCH_PRE_ARMv6 */ /* ARM pre v7 */ /* #undef arm_HOST_ARCH_PRE_ARMv7 */ -/* Define to empty if 'const' does not conform to ANSI C. */ +/* Define to empty if `const' does not conform to ANSI C. */ /* #undef const */ /* Define as a signed integer type capable of holding a process identifier. */ @@ -653,9 +654,35 @@ /* The minimum supported LLVM version number */ #define sUPPORTED_LLVM_VERSION_MIN (11) -/* Define as 'unsigned int' if doesn't define. */ +/* Define to `unsigned int' if does not define. */ /* #undef size_t */ -/* Define as 'fork' if 'vfork' does not work. */ +/* Define as `fork' if `vfork' does not work. */ /* #undef vfork */ +/* ghcautoconf.h.autoconf. Generated from ghcautoconf.h.autoconf.in by configure. */ +/* ghcautoconf.h.autoconf.in. Generated from configure.ac by autoheader. */ + +/* Define to the address where bug reports for this package should be sent. */ +/* #undef PACKAGE_BUGREPORT */ + +/* Define to the full name of this package. */ +/* #undef PACKAGE_NAME */ + +/* Define to the full name and version of this package. */ +/* #undef PACKAGE_STRING */ + +/* Define to the one symbol short name of this package. */ +/* #undef PACKAGE_TARNAME */ + +/* Define to the home page for this package. */ +/* #undef PACKAGE_URL */ + +/* Define to the version of this package. */ +/* #undef PACKAGE_VERSION */ + +/* ARM pre v6 */ +/* #undef arm_HOST_ARCH_PRE_ARMv6 */ + +/* ARM pre v7 */ +/* #undef arm_HOST_ARCH_PRE_ARMv7 */ #endif /* __GHCAUTOCONF_H__ */ diff --git a/libraries/containers/containers/include/containers.h b/libraries/containers/containers/include/containers.h new file mode 100644 --- /dev/null +++ b/libraries/containers/containers/include/containers.h @@ -0,0 +1,30 @@ +/* + * Common macros for containers + */ + +#ifndef HASKELL_CONTAINERS_H +#define HASKELL_CONTAINERS_H + +/* + * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro. + */ +#ifdef __GLASGOW_HASKELL__ +#include "MachDeps.h" +#endif + +#ifdef __GLASGOW_HASKELL__ +#define DEFINE_PATTERN_SYNONYMS 1 +#endif + +#ifdef __GLASGOW_HASKELL__ +# define USE_ST_MONAD 1 +#ifndef WORDS_BIGENDIAN +/* + * Unboxed arrays are broken on big-endian architectures. + * See https://gitlab.haskell.org/ghc/ghc/-/issues/16998 + */ +# define USE_UNBOXED_ARRAYS 1 +#endif +#endif + +#endif diff --git a/libraries/ghci/GHCi/BinaryArray.hs b/libraries/ghci/GHCi/BinaryArray.hs new file mode 100644 --- /dev/null +++ b/libraries/ghci/GHCi/BinaryArray.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-} +-- | Efficient serialisation for GHCi Instruction arrays +-- +-- Author: Ben Gamari +-- +module GHCi.BinaryArray(putArray, getArray) where + +import Prelude +import Foreign.Ptr +import Data.Binary +import Data.Binary.Put (putBuilder) +import qualified Data.Binary.Get.Internal as Binary +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Internal as BB +import qualified Data.Array.Base as A +import qualified Data.Array.IO.Internals as A +import qualified Data.Array.Unboxed as A +import GHC.Exts +import GHC.IO + +-- | An efficient serialiser of 'A.UArray'. +putArray :: Binary i => A.UArray i a -> Put +putArray (A.UArray l u _ arr#) = do + put l + put u + putBuilder $ byteArrayBuilder arr# + +byteArrayBuilder :: ByteArray# -> BB.Builder +byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#)) + where + go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a + go !inStart !inEnd k (BB.BufferRange outStart outEnd) + -- There is enough room in this output buffer to write all remaining array + -- contents + | inRemaining <= outRemaining = do + copyByteArrayToAddr arr# inStart outStart inRemaining + k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd) + -- There is only enough space for a fraction of the remaining contents + | otherwise = do + copyByteArrayToAddr arr# inStart outStart outRemaining + let !inStart' = inStart + outRemaining + return $! BB.bufferFull 1 outEnd (go inStart' inEnd k) + where + inRemaining = inEnd - inStart + outRemaining = outEnd `minusPtr` outStart + + copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () + copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) = + IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s' -> (# s', () #) + +-- | An efficient deserialiser of 'A.UArray'. +getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a) +getArray = do + l <- get + u <- get + arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <- + return $ unsafeDupablePerformIO $ A.newArray_ (l,u) + let go 0 _ = return () + go !remaining !off = do + Binary.readNWith n $ \ptr -> + copyAddrToByteArray ptr arr# off n + go (remaining - n) (off + n) + where n = min chunkSize remaining + go (I# (sizeofMutableByteArray# arr#)) 0 + return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr + where + chunkSize = 10*1024 + + copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld + -> Int -> Int -> IO () + copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) = + IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s' -> (# s', () #) + +-- this is inexplicably not exported in currently released array versions +unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e) +unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr) diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs new file mode 100644 --- /dev/null +++ b/libraries/ghci/GHCi/ResolvedBCO.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving, + BangPatterns, CPP #-} +module GHCi.ResolvedBCO + ( ResolvedBCO(..) + , ResolvedBCOPtr(..) + , isLittleEndian + ) where + +import Prelude -- See note [Why do we import Prelude here?] +import GHC.Data.SizedSeq +import GHCi.RemoteTypes +import GHCi.BreakArray + +import Data.Array.Unboxed +import Data.Binary +import GHC.Generics +import GHCi.BinaryArray + + +#include "MachDeps.h" + +isLittleEndian :: Bool +#if defined(WORDS_BIGENDIAN) +isLittleEndian = False +#else +isLittleEndian = True +#endif + +-- ----------------------------------------------------------------------------- +-- ResolvedBCO + +-- | A 'ResolvedBCO' is one in which all the 'Name' references have been +-- resolved to actual addresses or 'RemoteHValues'. +-- +-- Note, all arrays are zero-indexed (we assume this when +-- serializing/deserializing) +data ResolvedBCO + = ResolvedBCO { + resolvedBCOIsLE :: Bool, + resolvedBCOArity :: {-# UNPACK #-} !Int, + resolvedBCOInstrs :: UArray Int Word16, -- insns + resolvedBCOBitmap :: UArray Int Word64, -- bitmap + resolvedBCOLits :: UArray Int Word64, -- non-ptrs + resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs + } + deriving (Generic, Show) + +-- | The Binary instance for ResolvedBCOs. +-- +-- Note, that we do encode the endianness, however there is no support for mixed +-- endianness setups. This is primarily to ensure that ghc and iserv share the +-- same endianness. +instance Binary ResolvedBCO where + put ResolvedBCO{..} = do + put resolvedBCOIsLE + put resolvedBCOArity + putArray resolvedBCOInstrs + putArray resolvedBCOBitmap + putArray resolvedBCOLits + put resolvedBCOPtrs + get = ResolvedBCO + <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get + +data ResolvedBCOPtr + = ResolvedBCORef {-# UNPACK #-} !Int + -- ^ reference to the Nth BCO in the current set + | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue) + -- ^ reference to a previously created BCO + | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ()) + -- ^ reference to a static ptr + | ResolvedBCOPtrBCO ResolvedBCO + -- ^ a nested BCO + | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray) + -- ^ Resolves to the MutableArray# inside the BreakArray + deriving (Generic, Show) + +instance Binary ResolvedBCOPtr